diff options
Diffstat (limited to 'tests')
120 files changed, 14679 insertions, 7720 deletions
diff --git a/tests/all.tcl b/tests/all.tcl index 8d33488..7f57dc2 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -9,10 +9,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.4 -package require tcltest 2.1 +package require Tcl 8.5 +package require tcltest 2.2 package require Tk ;# This is the Tk test suite; fail early if no Tk! -tcltest::configure -testdir [file join [pwd] [file dirname [info script]]] +tcltest::configure {*}$argv +tcltest::configure -testdir [file normalize [file dirname [info script]]] +tcltest::configure -loadfile \ + [file join [tcltest::testsDirectory] constraints.tcl] tcltest::configure -singleproc 1 -eval tcltest::configure $argv tcltest::runAllTests diff --git a/tests/bell.test b/tests/bell.test index e7ddeb2..16fea0f 100644 --- a/tests/bell.test +++ b/tests/bell.test @@ -6,10 +6,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands test bell-1.1 {bell command} { @@ -45,18 +42,5 @@ test bell-1.8 {bell command} { } {} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/bgerror.test b/tests/bgerror.test index d534be8..fa33d31 100644 --- a/tests/bgerror.test +++ b/tests/bgerror.test @@ -6,10 +6,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands test bgerror-1.1 {bgerror / tkerror compat} { @@ -57,18 +54,5 @@ catch {rename tkerror {}} # to emulate. # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/bind.test b/tests/bind.test index 6de1fc1..9892fec 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands tk useinputmethods 0 @@ -216,8 +213,6 @@ test bind-5.1 {Tk_CreateBindingTable procedure} { .b.c bind foo } {} -testConstraint testcbind [llength [info commands testcbind]] - test bind-6.1 {Tk_DeleteBindTable procedure} { catch {destroy .b.c} canvas .b.c @@ -2054,190 +2049,191 @@ 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, -data, -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] } +# Note that the -data option is tested in bind-32.* because it has +# more demanding requirements in memory handling + test bind-23.1 {GetVirtualEventUid procedure} { list [catch {event info <<asd} msg] $msg } {1 {virtual event "<<asd" is badly formed}} @@ -2369,114 +2365,106 @@ test bind-24.14 {FindSequence procedure: no binding} { list [catch {.b.f bind $i <a>} msg] $msg } {0 {}} -test bind-25.1 {ParseEventDescription procedure} { - list [catch {bind .b \x7 test} msg] $msg -} {1 {bad ASCII character 0x7}} -test bind-25.2 {ParseEventDescription procedure} { - list [catch {bind .b "\x7f" test} msg] $msg -} {1 {bad ASCII character 0x7f}} -test bind-25.3 {ParseEventDescription procedure} { - list [catch {bind .b "\x4" test} msg] $msg -} {1 {bad ASCII character 0x4}} -test bind-25.4 {ParseEventDescription procedure} { +test bind-25.1 {ParseEventDescription procedure} -setup { setup +} -body { bind .b.f a test bind .b.f a -} {test} -test bind-25.5 {ParseEventDescription procedure: virtual} { - list [catch {bind .b <<>> foo} msg] $msg -} {1 {virtual event "<<>>" is badly formed}} -test bind-25.6 {ParseEventDescription procedure: virtual} { - list [catch {bind .b <<Paste foo} msg] $msg -} {1 {missing ">" in virtual binding}} -test bind-25.7 {ParseEventDescription procedure: virtual} { - list [catch {bind .b <<Paste> foo} msg] $msg -} {1 {missing ">" in virtual binding}} -test bind-25.8 {ParseEventDescription procedure: correctly terminate virtual} { - list [catch {bind .b <<Paste>>h foo} msg] $msg -} {1 {virtual events may not be composed}} -test bind-25.9 {ParseEventDescription procedure} { - list [catch {bind .b <> test} msg] $msg -} {1 {no event type or button # or keysym}} -test bind-25.10 {ParseEventDescription procedure: misinterpreted modifier} { +} -result test +test bind-25.2 {ParseEventDescription procedure: misinterpreted modifier} -setup { button .x +} -body { bind .x <Control-M> a bind .x <M-M> b - set x [lsort [bind .x]] + lsort [bind .x] +} -cleanup { destroy .x - set x -} {<Control-Key-M> <Meta-Key-M>} -test bind-25.11 {ParseEventDescription procedure} { +} -result {<Control-Key-M> <Meta-Key-M>} +test bind-25.3 {ParseEventDescription procedure} -setup { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 +} -body { bind .b.f <a---> {nothing} bind .b.f -} a -test bind-25.12 {ParseEventDescription procedure} { - list [catch {bind .b <a-- test} msg] $msg -} {1 {missing ">" in binding}} -test bind-25.13 {ParseEventDescription procedure} { - list [catch {bind .b <a-b> test} msg] $msg -} {1 {extra characters after detail in binding}} -test bind-25.14 {ParseEventDescription} { - setup - list [catch {bind .b <<abc {puts hi}} msg] $msg -} {1 {missing ">" in virtual binding}} -test bind-25.15 {ParseEventDescription} { - setup - list [catch {bind .b <<abc> {puts hi}} msg] $msg -} {1 {missing ">" in virtual binding}} -test bind-25.16 {ParseEventDescription} { +} -result a +test bind-25.4 {ParseEventDescription} -setup { setup +} -body { bind .b <<Shift-Paste>> {puts hi} bind .b -} {<<Shift-Paste>>} -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>} +} -result {<<Shift-Paste>>} +# Assorted error cases in event sequence parsing +foreach {testname testinfo} { + bind-25.5 {\x7 {bad ASCII character 0x7}} + bind-25.6 {\x7f {bad ASCII character 0x7f}} + bind-25.7 {\x4 {bad ASCII character 0x4}} + bind-25.8 {<<>> {virtual event "<<>>" is badly formed}} + bind-25.9 {<<Paste {missing ">" in virtual binding}} + bind-25.10 {<<Paste> {missing ">" in virtual binding}} + bind-25.11 {<<Paste>>h {virtual events may not be composed}} + bind-25.12 {<> "no event type or button # or keysym"} + bind-25.13 {<a-- {missing ">" in binding}} + bind-25.14 {<a-b> {extra characters after detail in binding}} + bind-25.15 {<<abc {missing ">" in virtual binding}} + bind-25.16 {<<abc> {missing ">" in virtual binding}} +} { + lassign $testinfo sequence errorMessage + test $testname {ParseEventDescription procedure error cases} \ + -setup { setup } \ + -body [list bind .b $sequence {puts hi}] \ + -returnCodes error -result $errorMessage +} +test bind-25.17 {ParseEventDescription} -setup { + setup +} -returnCodes error -body { + event add <<xyz>> <<abc>> +} -result {virtual event not allowed in definition of another virtual event} +# Modifier canonicalization tests +foreach {name check} { + bind-25.18 {{<Control- a>} <Control-Key-a>} + bind-25.19 {<Shift-a> <Shift-Key-a>} + bind-25.20 {<Lock-a> <Lock-Key-a>} + bind-25.21 {<Meta---a> <Meta-Key-a>} + bind-25.22 {<M-a> <Meta-Key-a>} + bind-25.23 {<Alt-a> <Alt-Key-a>} + bind-25.24 {<B1-a> <B1-Key-a>} + bind-25.25 {<B2-a> <B2-Key-a>} + bind-25.26 {<B3-a> <B3-Key-a>} + bind-25.27 {<B4-a> <B4-Key-a>} + bind-25.28 {<B5-a> <B5-Key-a>} + bind-25.29 {<Button1-a> <B1-Key-a>} + bind-25.30 {<Button2-a> <B2-Key-a>} + bind-25.31 {<Button3-a> <B3-Key-a>} + bind-25.32 {<Button4-a> <B4-Key-a>} + bind-25.33 {<Button5-a> <B5-Key-a>} + bind-25.34 {<M1-a> <Mod1-Key-a>} + bind-25.35 {<M2-a> <Mod2-Key-a>} + bind-25.36 {<M3-a> <Mod3-Key-a>} + bind-25.37 {<M4-a> <Mod4-Key-a>} + bind-25.38 {<M5-a> <Mod5-Key-a>} + bind-25.39 {<Mod1-a> <Mod1-Key-a>} + bind-25.40 {<Mod2-a> <Mod2-Key-a>} + bind-25.41 {<Mod3-a> <Mod3-Key-a>} + bind-25.42 {<Mod4-a> <Mod4-Key-a>} + bind-25.43 {<Mod5-a> <Mod5-Key-a>} + bind-25.44 {<Double-a> <Double-Key-a>} + bind-25.45 {<Triple-a> <Triple-Key-a>} + bind-25.46 {{<Double 1>} <Double-Button-1>} + bind-25.47 {<Triple-1> <Triple-Button-1>} + bind-25.48 {{<M1-M2 M3-M4 B1-Control-a>} + <Control-B1-Mod1-Mod2-Mod3-Mod4-Key-a>} + bind-25.49 {<Extended-Return> <Extended-Key-Return>} } { - test bind-25.$i {modifier names} { + lassign $check 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] { @@ -2504,72 +2492,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 @@ -2586,46 +2599,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] @@ -2673,7 +2681,7 @@ test bind-31.2 {MouseWheel events} { event gen .b.f <MouseWheel> -delta 120 set x } {120} -test bind-31.2 {MouseWheel events} { +test bind-31.3 {MouseWheel events} { setup set x {} bind .b.f <MouseWheel> {set x "%D %x %y"} @@ -2681,8 +2689,64 @@ test bind-31.2 {MouseWheel events} { set x } {240 10 30} +test bind-32.1 {virtual event user_data field - bad generation} { + setup + # Check no confusion, since Focus events use %d for something else + list [catch {event gen .b.f <FocusIn> -data foo} msg] $msg +} {1 {<FocusIn> event doesn't accept "-data" option}} +test bind-32.2 {virtual event user_data field - NULL, synch} { + setup + set x {} + bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} + event gen .b.f <<TestUserData>> + set x +} {TestUserData >{}<} +test bind-32.3 {virtual event user_data field - shared, synch} { + setup + set x {} + bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} + event gen .b.f <<TestUserData>> -data "foo bar" + set x +} {TestUserData >foo bar<} +test bind-32.4 {virtual event user_data field - unshared, synch} { + setup + set x {} + bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} + event gen .b.f <<TestUserData>> -data [string index abc 1] + set x +} {TestUserData >b<} +# Note that asynch event handling can only really catch any potential +# extra errors when used in combination with a tool like Purify or +# Valgrind. Such testing is rarely done, but at least any problem with +# reference handling will eventually show up with these tests... +test bind-32.5 {virtual event user_data field - NULL, asynch} { + setup + set x {} + bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} + event gen .b.f <<TestUserData>> -when head + list $x [update] $x +} {{} {} {TestUserData >{}<}} +test bind-32.6 {virtual event user_data field - shared, asynch} { + setup + set x {} + bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} + event gen .b.f <<TestUserData>> -data "foo bar" -when head + list $x [update] $x +} {{} {} {TestUserData >foo bar<}} +test bind-32.7 {virtual event user_data field - unshared, asynch} { + setup + set x {} + bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} + event gen .b.f <<TestUserData>> -data [string index abc 1] -when head + list $x [update] $x +} {{} {} {TestUserData >b<}} + destroy .b # cleanup -::tcltest::cleanupTests +cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/bitmap.test b/tests/bitmap.test index e79866a..6e2255c 100644 --- a/tests/bitmap.test +++ b/tests/bitmap.test @@ -7,14 +7,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint testbitmap [llength [info commands testbitmap]] - test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} testbitmap { set x gray25 lindex $x 0 @@ -92,18 +87,5 @@ test bitmap-4.1 {FreeBitmapObjProc} testbitmap { destroy .t # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/border.test b/tests/border.test index e38502a..30aed91 100644 --- a/tests/border.test +++ b/tests/border.test @@ -6,14 +6,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint testborder [llength [info commands testborder]] - if {[testConstraint pseudocolor8]} { toplevel .t -visual {pseudocolor 8} -colormap new wm geom .t +0+0 @@ -129,31 +124,31 @@ test border-4.1 {FreeBorderObjProc} testborder { catch {destroy .b} button .b -test get-2.1 {Tk_GetReliefFromObj} { +test border-5.1 {Tk_GetReliefFromObj} { .b configure -relief flat .b cget -relief } {flat} -test get-2.2 {Tk_GetReliefFromObj} { +test border-5.2 {Tk_GetReliefFromObj} { .b configure -relief groove .b cget -relief } {groove} -test get-2.3 {Tk_GetReliefFromObj} { +test border-5.3 {Tk_GetReliefFromObj} { .b configure -relief raised .b cget -relief } {raised} -test get-2.3 {Tk_GetReliefFromObj} { +test border-5.4 {Tk_GetReliefFromObj} { .b configure -relief ridge .b cget -relief } {ridge} -test get-2.3 {Tk_GetReliefFromObj} { +test border-5.5 {Tk_GetReliefFromObj} { .b configure -relief solid .b cget -relief } {solid} -test get-2.3 {Tk_GetReliefFromObj} { +test border-5.6 {Tk_GetReliefFromObj} { .b configure -relief sunken .b cget -relief } {sunken} -test get-2.4 {Tk_GetReliefFromObj - error} { +test border-5.7 {Tk_GetReliefFromObj - error} { list [catch {.b configure -relief upanddown} msg] $msg } {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}} @@ -162,18 +157,5 @@ if {[testConstraint pseudocolor8]} { } # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/button.test b/tests/button.test index c1bfb46..927aac0 100644 --- a/tests/button.test +++ b/tests/button.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands proc bogusTrace args { @@ -43,7 +40,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}} @@ -53,7 +52,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} @@ -73,51 +74,70 @@ 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}} - {-offvalue 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}} + {-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}} {-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}} + {-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 { - test button-1.$i {configuration options} testImageType { - $w configure $name [lindex $test 1] - lindex [$w configure $name] 4 - } [lindex $test 2] + lassign $test name value okResult badValue badResult classes + foreach w {.l .b .c .r} hasOption $classes { + set classname [winfo class $w] + if {$hasOption} { + test button-1.$i "configuration option $name for $classname" \ + -constraints testImageType -body " + $w configure $name [list $value] + lindex \[$w configure $name] 4 + " -result $okResult incr i - if {[lindex $test 3] != ""} { - test button-1.$i {configuration options} testImageType { - list [catch {$w configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + if {$badValue ne ""} { + test button-1.$i "configuration option $name for $classname" \ + -constraints testImageType \ + -body [list $w configure $name $badValue] \ + -returnCodes error -result $badResult + incr i } $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 - } "1 {unknown option \"$name\"}" + test button-1.$i "configuration option $name for $classname" \ + -constraints testImageType \ + -body [list $w configure $name $value] \ + -returnCodes error -result "unknown option \"$name\"" + incr i } } - incr i } test button-1.$i {configuration options} { + # Additional check to make sure that -selectcolor may be empty in + # checkbox widgets .c configure -selectcolor {} } {} @@ -216,7 +236,7 @@ test button-4.13 {ButtonWidgetCmd procedure, "cget" option} { } {1 {unknown option "-onvalue"}} test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { llength [.c configure] -} {39} +} {41} test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { list [catch {.b configure -gorp} msg] $msg } {1 {unknown option "-gorp"}} @@ -254,23 +274,25 @@ test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { .r deselect set value2 } {} -test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} -body { set value 1 trace variable value w bogusTrace set result [list [catch {.c deselect} msg] $msg $errorInfo $value] trace vdelete value w bogusTrace set result -} {1 {can't set "value": trace aborted} {can't set "value": trace aborted +} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted while executing +* ".c deselect"} 0} -test button-4.25 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.25 {ButtonWidgetCmd procedure, "deselect" option} -body { set value2 red trace variable value2 w bogusTrace set result [list [catch {.r deselect} msg] $msg $errorInfo $value2] trace vdelete value2 w bogusTrace set result -} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted +} -match glob -result {1 {can't set "value2": trace aborted} {*trace aborted while executing +* ".r deselect"} {}} test button-4.26 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.b flash foo} msg] $msg @@ -341,14 +363,15 @@ test button-4.41 {ButtonWidgetCmd procedure, "select" option} { .r select set value2 } {red} -test button-4.42 {ButtonWidgetCmd procedure, "select" option} { +test button-4.42 {ButtonWidgetCmd procedure, "select" option} -body { set value2 yellow trace variable value2 w bogusTrace set result [list [catch {.r select} msg] $msg $errorInfo $value2] trace vdelete value2 w bogusTrace set result -} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted +} -match glob -result {1 {can't set "value2": trace aborted} {*trace aborted while executing +* ".r select"} red} test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} { list [catch {.l toggle} msg] $msg @@ -372,25 +395,27 @@ test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { .c toggle lappend result $value } {sunshine rain sunshine} -test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} -body { .c configure -onvalue xyz -offvalue abc set value xyz trace variable value w bogusTrace set result [list [catch {.c toggle} msg] $msg $errorInfo $value] trace vdelete value w bogusTrace set result -} {1 {can't set "value": trace aborted} {can't set "value": trace aborted +} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted while executing +* ".c toggle"} abc} -test button-4.49 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.49 {ButtonWidgetCmd procedure, "toggle" option} -body { .c configure -onvalue xyz -offvalue abc set value abc trace variable value w bogusTrace set result [list [catch {.c toggle} msg] $msg $errorInfo $value] trace vdelete value w bogusTrace set result -} {1 {can't set "value": trace aborted} {can't set "value": trace aborted +} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted while executing +* ".c toggle"} xyz} test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} { catch {unset value}; set value(1) 1; @@ -430,7 +455,7 @@ test button-6.2 {ConfigureButton - textvariable trace} { set x New lindex [.b1 configure -text] 4 } {From-y} -test button-6.2 {ConfigureButton - variable traces} { +test button-6.2a {ConfigureButton - variable traces} { catch {destroy .b1} catch {unset x} checkbutton .b1 -variable x @@ -626,7 +651,7 @@ test button-9.4 {TkInvokeButton procedure} { .b1 invoke lappend result $x } {0 red red} -test button-9.5 {TkInvokeButton procedure} { +test button-9.5 {TkInvokeButton procedure} -body { catch {destroy .b1} radiobutton .b1 -variable x -value red set x green @@ -634,8 +659,9 @@ test button-9.5 {TkInvokeButton procedure} { set result [list [catch {.b1 invoke} msg] $msg $errorInfo $x] trace vdelete x w bogusTrace set result -} {1 {can't set "x": trace aborted} {can't set "x": trace aborted +} -match glob -result {1 {can't set "x": trace aborted} {*trace aborted while executing +* ".b1 invoke"} red} test button-9.6 {TkInvokeButton procedure} { deleteWindows @@ -806,5 +832,5 @@ deleteWindows option clear # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/canvImg.test b/tests/canvImg.test index 083c5c0..1dffc5e 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands eval image delete [image names] @@ -129,13 +126,14 @@ test canvImg-5.1 {DeleteImage procedure} testImageType { .c delete all .c create image 50 100 -image xyzzy -tags i1 update + set names [lsort [image names]] image delete xyzzy set z {} - set names [lsort [image names]] + set names2 [lsort [image names]] .c delete i1 update - list $names $z [lsort [image names]] -} {{foo foo2 xyzzy} {} {foo foo2}} + list $names $names2 $z [lsort [image names]] +} {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}} test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} { .c delete all .c create image 50 100 -tags i1 @@ -225,37 +223,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 {*}$rectCoords + .c gettags [.c find closest {*}$testPoint] + } $result } .c delete all @@ -390,18 +387,5 @@ test canvImg-11.3 {ImageChangedProc procedure} testImageType { } {{foo2 display 0 0 20 40 50 40}} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/canvPs.test b/tests/canvPs.test index 387a447..f2df447 100644 --- a/tests/canvPs.test +++ b/tests/canvPs.test @@ -7,50 +7,66 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile - canvas .c -width 400 -height 300 -bd 2 -relief sunken .c create rectangle 20 20 80 80 -fill red pack .c update -test canvPs-1.1 {test writing to a file} {unixOrPc} { - removeFile foo.ps - .c postscript -file foo.ps - file exists foo.ps -} 1 -test canvPs-1.2 {test writing to a file, idempotency} {unixOrPc} { +test canvPs-1.1 {test writing to a file} -constraints { + unixOrPc +} -setup { + set foo [makeFile {} foo.ps] +} -body { + .c postscript -file $foo + file exists $foo +} -cleanup { removeFile foo.ps - removeFile bar.ps - .c postscript -file foo.ps - .c postscript -file bar.ps +} -result 1 +test canvPs-1.2 {test writing to a file, idempotency} -constraints { + unixOrPc +} -setup { + set foo [makeFile {} foo.ps] + set bar [makeFile {} bar.ps] +} -body { + .c postscript -file $foo + .c postscript -file $bar set status ok - if {[file size bar.ps] != [file size foo.ps]} { + if {[file size $bar] != [file size $foo]} { set status broken } set status -} ok - -test canvPs-2.1 {test writing to a channel} {unixOrPc} { +} -cleanup { removeFile foo.ps - set chan [open foo.ps w] + removeFile bar.ps +} -result ok + +test canvPs-2.1 {test writing to a channel} -constraints { + unixOrPc +} -setup { + set foo [makeFile {} foo.ps] + file delete $foo +} -body { + set chan [open $foo w] fconfigure $chan -translation lf .c postscript -channel $chan close $chan - file exists foo.ps -} 1 -test canvPs-2.2 {test writing to channel, idempotency} {unixOrPc} { + file exists $foo +} -cleanup { removeFile foo.ps - removeFile bar.ps - set c1 [open foo.ps w] - set c2 [open bar.ps w] +} -result 1 +test canvPs-2.2 {test writing to channel, idempotency} -constraints { + unixOrPc +} -setup { + set foo [makeFile {} foo.ps] + set bar [makeFile {} bar.ps] + file delete $foo + file delete $bar +} -body { + set c1 [open $foo w] + set c2 [open $bar w] fconfigure $c1 -translation lf fconfigure $c2 -translation lf .c postscript -channel $c1 @@ -58,42 +74,65 @@ test canvPs-2.2 {test writing to channel, idempotency} {unixOrPc} { close $c1 close $c2 set status ok - if {[file size bar.ps] != [file size foo.ps]} { + if {[file size $bar] != [file size $foo]} { set status broken } set status -} ok -test canvPs-2.3 {test writing to channel and file, same output} {unixOnly} { +} -cleanup { removeFile foo.ps removeFile bar.ps - set c1 [open foo.ps w] +} -result ok +test canvPs-2.3 {test writing to channel and file, same output} -constraints { + unix +} -setup { + set foo [makeFile {} foo.ps] + set bar [makeFile {} bar.ps] + file delete $foo + file delete $bar +} -body { + set c1 [open $foo w] fconfigure $c1 -translation lf .c postscript -channel $c1 close $c1 - .c postscript -file bar.ps + .c postscript -file $bar set status ok - if {[file size foo.ps] != [file size bar.ps]} { + if {[file size $foo] != [file size $bar]} { set status broken } set status -} ok -test canvPs-2.4 {test writing to channel and file, same output} {pcOnly} { +} -cleanup { removeFile foo.ps removeFile bar.ps - set c1 [open foo.ps w] +} -result ok +test canvPs-2.4 {test writing to channel and file, same output} -constraints { + win +} -setup { + set foo [makeFile {} foo.ps] + set bar [makeFile {} bar.ps] + file delete $foo + file delete $bar +} -body { + set c1 [open $foo w] fconfigure $c1 -translation crlf .c postscript -channel $c1 close $c1 - .c postscript -file bar.ps + .c postscript -file $bar set status ok - if {[file size foo.ps] != [file size bar.ps]} { + if {[file size $foo] != [file size $bar]} { set status broken } set status -} ok - -test canvPs-3.1 {test ps generation with an embedded window} {notAqua} { +} -cleanup { + removeFile foo.ps removeFile bar.ps +} -result ok + +test canvPs-3.1 {test ps generation with an embedded window} -setup { + set bar [makeFile {} bar.ps] + file delete $bar +} -constraints { + notAqua +} -body { destroy .c pack [canvas .c -width 200 -height 200 -background white] .c create rect 20 20 150 150 -tags rect0 -dash . -width 2 @@ -101,26 +140,32 @@ test canvPs-3.1 {test ps generation with an embedded window} {notAqua} { -dash {4 4} -stipple question -outline red -fill green image create photo logo \ - -file [file join $tk_library images pwrdLogo150.gif] + -file [file join [file dirname [info script]] pwrdLogo150.gif] .c create image 200 50 -image logo -anchor nw entry .c.e -background pink -foreground blue -width 14 .c.e insert 0 "we gonna be postscripted" .c create window 50 180 -anchor nw -window .c.e update - .c postscript -file bar.ps - file exists bar.ps -} 1 -test canvPs-3.2 {test ps generation with an embedded window not mapped} {} { + .c postscript -file $bar + file exists $bar +} -cleanup { removeFile bar.ps +} -result 1 +test canvPs-3.2 {test ps generation with an embedded window not mapped} -setup { + set bar [makeFile {} bar.ps] + file delete $bar +} -body { destroy .c pack [canvas .c -width 200 -height 200 -background white] entry .c.e -background pink -foreground blue -width 14 .c.e insert 0 "we gonna be postscripted" .c create window 50 180 -anchor nw -window .c.e - .c postscript -file bar.ps - file exists bar.ps -} 1 + .c postscript -file $bar + file exists $bar +} -cleanup { + removeFile bar.ps +} -result 1 test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} {} { destroy .c @@ -130,8 +175,7 @@ test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498 } 0 # cleanup -removeFile foo.ps -removeFile bar.ps +unset -nocomplain foo bar deleteWindows -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/canvPsBmap.tcl b/tests/canvPsBmap.tcl index 9bd5f9d..4a7a7e2 100644 --- a/tests/canvPsBmap.tcl +++ b/tests/canvPsBmap.tcl @@ -23,48 +23,50 @@ pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1 canvas $c -width 6i -height 6i -bd 2 -relief sunken pack $c -expand yes -fill both -padx 2m -pady 2m +set canvPsBmapImageDir [file join [file dirname [info script]] images] + $c create bitmap 0.5i 0.5i \ - -bitmap @[file join $tk_library demos/images/flagdown.bmp] \ + -bitmap @[file join $canvPsBmapImageDir flagdown.xbm] \ -background {} -foreground black -anchor nw $c create rect 0.47i 0.47i 0.53i 0.53i -fill {} -outline black $c create bitmap 3.0i 0.5i \ - -bitmap @[file join $tk_library demos/images/flagdown.bmp] \ + -bitmap @[file join $canvPsBmapImageDir flagdown.xbm] \ -background {} -foreground black -anchor n $c create rect 2.97i 0.47i 3.03i 0.53i -fill {} -outline black $c create bitmap 5.5i 0.5i \ - -bitmap @[file join $tk_library demos/images/flagdown.bmp] \ + -bitmap @[file join $canvPsBmapImageDir flagdown.xbm] \ -background black -foreground white -anchor ne $c create rect 5.47i 0.47i 5.53i 0.53i -fill {} -outline black $c create bitmap 0.5i 3.0i \ - -bitmap @[file join $tk_library demos/images/face.bmp] \ + -bitmap @[file join $canvPsBmapImageDir face.xbm] \ -background {} -foreground black -anchor w $c create rect 0.47i 2.97i 0.53i 3.03i -fill {} -outline black $c create bitmap 3.0i 3.0i \ - -bitmap @[file join $tk_library demos/images/face.bmp] \ + -bitmap @[file join $canvPsBmapImageDir face.xbm] \ -background {} -foreground black -anchor center $c create rect 2.97i 2.97i 3.03i 3.03i -fill {} -outline black $c create bitmap 5.5i 3.0i \ - -bitmap @[file join $tk_library demos/images/face.bmp] \ + -bitmap @[file join $canvPsBmapImageDir face.xbm] \ -background blue -foreground black -anchor e $c create rect 5.47i 2.97i 5.53i 3.03i -fill {} -outline black $c create bitmap 0.5i 5.5i \ - -bitmap @[file join $tk_library demos/images/flagup.bmp] \ + -bitmap @[file join $canvPsBmapImageDir flagup.xbm] \ -background black -foreground white -anchor sw $c create rect 0.47i 5.47i 0.53i 5.53i -fill {} -outline black $c create bitmap 3.0i 5.5i \ - -bitmap @[file join $tk_library demos/images/flagup.bmp] \ + -bitmap @[file join $canvPsBmapImageDir flagup.xbm] \ -background green -foreground white -anchor s $c create rect 2.97i 5.47i 3.03i 5.53i -fill {} -outline black $c create bitmap 5.5i 5.5i \ - -bitmap @[file join $tk_library demos/images/flagup.bmp] \ + -bitmap @[file join $canvPsBmapImageDir flagup.xbm] \ -background {} -foreground black -anchor se $c create rect 5.47i 5.47i 5.53i 5.53i -fill {} -outline black diff --git a/tests/canvPsImg.tcl b/tests/canvPsImg.tcl index 30cef31..c06aeaa 100644 --- a/tests/canvPsImg.tcl +++ b/tests/canvPsImg.tcl @@ -67,9 +67,11 @@ foreach l { monochrome gray color } { pack .t.$l -in .t.top.r -anchor w } -set BitmapImage [image create bitmap -file $tk_library/demos/images/face.bmp \ +set BitmapImage [image create bitmap \ + -file [file join [file dirname [info script]] face.xbm] \ -background white -foreground black] -set PhotoImage [image create photo -file $tk_library/demos/images/teapot.ppm] +set PhotoImage [image create photo \ + -file [file join [file dirname [info script]] teapot.ppm]] BuildTestImage diff --git a/tests/canvRect.test b/tests/canvRect.test index 94fd425..b6c828e 100644 --- a/tests/canvRect.test +++ b/tests/canvRect.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands canvas .c -width 400 -height 300 -bd 2 -relief sunken @@ -23,22 +20,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 } @@ -322,18 +324,5 @@ end } # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/canvText.test b/tests/canvText.test index 9566769..070011b 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands canvas .c -width 400 -height 300 -bd 2 -relief sunken @@ -34,18 +31,19 @@ foreach test { {-stipple gray50 gray50 xyz {bitmap "xyz" not defined}} {-tags {test a b c} {test a b c} {} {}} {-text xyz xyz {} {}} + {-underline 0 0 xyz {expected integer but got "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 } @@ -402,7 +400,7 @@ test canvText-9.15 {TextInsert procedure: cursor doesn't move} { .c dchars test 7 9 .c index test insert } {5} - + test canvText-10.1 {TextToPoint procedure} { .c coords test 0 0 .c itemconfig test -text 0 -anchor center @@ -423,15 +421,15 @@ test canvText-11.2 {TextToArea procedure} { test canvText-12.1 {ScaleText procedure} { .c coords test 100 100 .c scale all 50 50 2 2 - .c coords test -} {150.0 150.0} + format {%.6g %.6g} {*}[.c coords test] +} {150 150} test canvText-13.1 {TranslateText procedure} { .c coords test 100 100 .c move all 10 10 - .c coords test -} {110.0 110.0} - + format {%.6g %.6g} {*}[.c coords test] +} {110 110} + .c itemconfig test -text "abcdefghijklmno" -anchor nw .c select from test 5 .c select to test 8 @@ -458,6 +456,9 @@ test canvText-14.4 {GetTextIndex procedure: select error} { test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} { list [catch {.c index test xyz} msg] $msg } {1 {bad index "xyz"}} +test canvText-14.6 {select clear errors} -body { + .c select clear test +} -returnCodes error -result "wrong \# args: should be \".c select clear\"" test canvText-15.1 {SetTextCursor procedure} { .c itemconfig -text "abcdefg" @@ -480,7 +481,7 @@ test canvText-17.1 {TextToPostscript procedure} { .c delete all .c config -height 300 -highlightthickness 0 -bd 0 update - .c create text 100 100 -tags test + .c create text 100 100 -tags test .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax] .c itemconfig test -anchor n -fill black set x [.c postscript] @@ -491,7 +492,7 @@ test canvText-17.1 {TextToPostscript procedure} { \[(000)\] \[(000)\] \[(00)\] -] $ay -0.5 0 0 false DrawText +] $ay -0.5 0.0 0 false DrawText grestore restore showpage @@ -561,7 +562,7 @@ test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} { + ([font measure {Arial 28 bold} "Y"] / 2)}] set y1 [expr {18 + ($metrics(-linespace) / 2)}] set y2 [expr {160 + ($metrics(-linespace) / 2)}] - + lappend results [$c index tbox1 @$x,$y1] lappend results [$c index tbox2 @$x,$y2] @@ -570,18 +571,5 @@ test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} { # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/canvWind.test b/tests/canvWind.test index 6911341..9844ff0 100644 --- a/tests/canvWind.test +++ b/tests/canvWind.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} { @@ -128,18 +125,5 @@ test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} { catch {destroy .t} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/canvas.test b/tests/canvas.test index cc711db..6fea894 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # XXX - This test file is woefully incomplete. At present, only a @@ -20,56 +17,64 @@ canvas .c pack .c update set i 1 -foreach test { - {-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"}} - {-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"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} - {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} - {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}} - {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} - {-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}} - {-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"}} - {-takefocus "any string" "any string" {} {}} - {-width 402 402 xyz {bad screen distance "xyz"}} - {-xscrollcommand {Some command} {Some command} {} {}} - {-yscrollcommand {Another command} {Another command} {} {}} +foreach {testname testinfo} { + canvas-1.1 {-background #ff0000 #ff0000 + non-existent {unknown color name "non-existent"}} + canvas-1.2 {-bg #ff0000 #ff0000 + non-existent {unknown color name "non-existent"}} + canvas-1.3 {-bd 4 4 badValue {bad screen distance "badValue"}} + canvas-1.4 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + canvas-1.5 {-closeenough 24 24.0 + bogus {expected floating-point number but got "bogus"}} + canvas-1.6 {-confine true 1 silly {expected boolean value but got "silly"}} + canvas-1.7 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + canvas-1.8 {-height 2.1 2 x42 {bad screen distance "x42"}} + canvas-1.9 {-highlightbackground #112233 #112233 + ugly {unknown color name "ugly"}} + canvas-1.10 {-highlightcolor #110022 #110022 + bogus {unknown color name "bogus"}} + canvas-1.11 {-highlightthickness 18 18 + badValue {bad screen distance "badValue"}} + canvas-1.12 {-insertbackground #110022 #110022 + bogus {unknown color name "bogus"}} + canvas-1.13 {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} + canvas-1.14 {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} + canvas-1.15 {-insertontime 100 100 3.2 {expected integer but got "3.2"}} + canvas-1.16 {-insertwidth 1.3 1 6x {bad screen distance "6x"}} + canvas-1.17 {-relief groove groove + 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + canvas-1.18 {-selectbackground #110022 #110022 + bogus {unknown color name "bogus"}} + canvas-1.19 {-selectborderwidth 1.3 1 + badValue {bad screen distance "badValue"}} + canvas-1.20 {-selectforeground #654321 #654321 + bogus {unknown color name "bogus"}} + canvas-1.21 {-takefocus "any string" "any string" {} {}} + canvas-1.22 {-width 402 402 xyz {bad screen distance "xyz"}} + canvas-1.23 {-xscrollcommand {Some command} {Some command} {} {}} + canvas-1.24 {-yscrollcommand {Another command} {Another command} {} {}} } { - set name [lindex $test 0] - test canvas-1.$i {configuration options} { - .c configure $name [lindex $test 1] + lassign $testinfo name goodValue goodResult badValue badResult + test $testname-good "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 $testname-bad "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 } - -test canvas-1.40 {configure throws error on bad option} { +test canvas-1.25 {configure throws error on bad option} { set res [list [catch {.c configure -gorp foo}]] .c create rect 10 10 100 100 lappend res [catch {.c configure -gorp foo}] set res } [list 1 1] - catch {destroy .c} canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \ -highlightthickness 0 @@ -92,7 +97,7 @@ test canvas-2.3 {CanvasWidgetCmd, xview option} { .c xview scroll 2 units update lappend x [.c xview] -} {{0 0.3} {0.4 0.7}} +} {{0.0 0.3} {0.4 0.7}} test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} { # This test gives slightly different results on platforms such # as NetBSD. I don't know why... @@ -118,7 +123,7 @@ test canvas-3.1 {CanvasWidgetCmd, yview option} { .c yview scroll 3 units update lappend x [.c yview] -} {{0 0.5} {0.1875 0.6875}} +} {{0.0 0.5} {0.1875 0.6875}} test canvas-3.2 {CanvasWidgetCmd, yview option} { .c configure -xscrollincrement 40 -yscrollincrement 0 .c yview moveto 0 @@ -127,7 +132,7 @@ test canvas-3.2 {CanvasWidgetCmd, yview option} { .c yview scroll 2 units update lappend x [.c yview] -} {{0 0.5} {0.1 0.6}} +} {{0.0 0.5} {0.1 0.6}} test canvas-4.1 {ButtonEventProc procedure} { deleteWindows @@ -190,20 +195,22 @@ test canvas-6.5 {CanvasSetOrigin procedure} { .c canvasy 0 } {55.0} -set l [interp hidden] deleteWindows -test canvas-7.1 {canvas widget vs hidden commands} { +set l [lsort [interp hidden]] +test canvas-7.1 {canvas widget vs hidden commands} -setup { catch {destroy .c} +} -body { canvas .c interp hide {} .c destroy .c - list [winfo children .] [interp hidden] -} [list {} $l] + list [winfo children .] [lsort [interp hidden]] +} -result [list {} $l] -test canvas-8.1 {canvas arc bbox} { +test canvas-8.1 {canvas arc bbox} -setup { catch {destroy .c} canvas .c +} -body { .c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1 set arcBox [.c bbox arc1] .c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2 @@ -211,21 +218,23 @@ test canvas-8.1 {canvas arc bbox} { .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3 set pieBox [.c bbox arc3] list $arcBox $coordBox $pieBox -} {{48 21 100 94} {248 21 300 94} {398 21 500 112}} -test canvas-9.1 {canvas id creation and deletion} { +} -result {{48 21 100 94} {248 21 300 94} {398 21 500 112}} + +test canvas-9.1 {canvas id creation and deletion} -setup { + catch {destroy .c} + canvas .c +} -body { # With Tk 8.0.4 the ids are now stored in a hash table. You # can use this test as a performance test with older versions # by changing the value of size. set size 15 - catch {destroy .c} - set c [canvas .c] for {set i 0} {$i < $size} {incr i} { set x [expr {-10 + 3*$i}] for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { - $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ + .c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ -outline black -fill blue -tags rect - $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ + .c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ -anchor center -tags text } } @@ -234,136 +243,150 @@ test canvas-9.1 {canvas id creation and deletion} { # table changes. set time [lindex [time { - foreach id [$c find withtag all] { - $c lower $id - $c raise $id - $c find withtag $id - $c bind <Return> $id {} - $c delete $id + foreach id [.c find withtag all] { + .c lower $id + .c raise $id + .c find withtag $id + .c bind <Return> $id {} + .c delete $id } }] 0] set x "" -} {} -test canvas-10.1 {find items using tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 60 40 80 -fill yellow -tag [list b a] - .c create oval 20 100 40 120 -fill green -tag [list c b] - .c create oval 20 140 40 160 -fill blue -tag [list b] - .c create oval 20 180 40 200 -fill bisque -tag [list a d e] - .c create oval 20 220 40 240 -fill bisque -tag b - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - set res {} - lappend res [.c find withtag {!a}] - lappend res [.c find withtag {b&&c}] - lappend res [.c find withtag {b||c}] - lappend res [.c find withtag {a&&!b}] - lappend res [.c find withtag {!b&&!c}] - lappend res [.c find withtag {d&&a&&c&&b}] - lappend res [.c find withtag {b^a}] - lappend res [.c find withtag {(a&&!b)||(!a&&b)}] - lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }] - lappend res [.c find withtag {a&&!(c||d)}] - lappend res [.c find withtag {d&&"tag with spaces"}] - lappend res [.c find withtag "tag with spaces"] -} {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7} -test canvas-10.2 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {&&c}} err - set err -} {Unexpected operator in tag search expression} -test canvas-10.3 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {!!c}} err - set err -} {Too many '!' in tag search expression} -test canvas-10.4 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {b||}} err - set err -} {Missing tag in tag search expression} -test canvas-10.5 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {b&&(c||)}} err - set err -} {Unexpected operator in tag search expression} -test canvas-10.6 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {d&&""}} err - set err -} {Null quoted tag string in tag search expression} -test canvas-10.7 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag "d&&\"tag with spaces"} err - set err -} {Missing endquote in tag search expression} -test canvas-10.8 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {a&&"tag with spaces"z}} err - set err -} {Invalid boolean operator in tag search expression} -test canvas-10.9 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {a&&b&c}} err - set err -} {Singleton '&' in tag search expression} -test canvas-10.10 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {a||b|c}} err - set err -} {Singleton '|' in tag search expression} -test canvas-10.11 {backward compatility - strange tags that are not expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] - .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " } -} {1} -test canvas-10.12 {multple events bound to same tag expr} { - catch {destroy .c} - canvas .c - .c bind {a && b} <Enter> {puts Enter} - .c bind {a && b} <Leave> {puts Leave} -} {} +} -result {} +test canvas-10.1 {find items using tag expressions} -setup { + catch {destroy .c} + canvas .c +} -body { + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 60 40 80 -fill yellow -tag [list b a] + .c create oval 20 100 40 120 -fill green -tag [list c b] + .c create oval 20 140 40 160 -fill blue -tag [list b] + .c create oval 20 180 40 200 -fill bisque -tag [list a d e] + .c create oval 20 220 40 240 -fill bisque -tag b + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + set res {} + lappend res [.c find withtag {!a}] + lappend res [.c find withtag {b&&c}] + lappend res [.c find withtag {b||c}] + lappend res [.c find withtag {a&&!b}] + lappend res [.c find withtag {!b&&!c}] + lappend res [.c find withtag {d&&a&&c&&b}] + lappend res [.c find withtag {b^a}] + lappend res [.c find withtag {(a&&!b)||(!a&&b)}] + lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }] + lappend res [.c find withtag {a&&!(c||d)}] + lappend res [.c find withtag {d&&"tag with spaces"}] + lappend res [.c find withtag "tag with spaces"] +} -result {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7} +test canvas-10.2 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {&&c} +} -returnCodes error -result {Unexpected operator in tag search expression} +test canvas-10.3 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {!!c} +} -returnCodes error -result {Too many '!' in tag search expression} +test canvas-10.4 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {b||} +} -returnCodes error -result {Missing tag in tag search expression} +test canvas-10.5 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {b&&(c||)} +} -returnCodes error -result {Unexpected operator in tag search expression} +test canvas-10.6 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {d&&""} +} -returnCodes error -result {Null quoted tag string in tag search expression} +test canvas-10.7 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag "d&&\"tag with spaces" +} -returnCodes error -result {Missing endquote in tag search expression} +test canvas-10.8 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {a&&"tag with spaces"z} +} -returnCodes error -result {Invalid boolean operator in tag search expression} +test canvas-10.9 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {a&&b&c} +} -returnCodes error -result {Singleton '&' in tag search expression} +test canvas-10.10 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {a||b|c} +} -returnCodes error -result {Singleton '|' in tag search expression} +test canvas-10.11 {backward compatility - strange tags that are not expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] +} -body { + .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " } +} -result 1 +test canvas-10.12 {multple events bound to same tag expr} -setup { + catch {destroy .c} + canvas .c +} -body { + .c bind {a && b} <Enter> {puts Enter} + .c bind {a && b} <Leave> {puts Leave} +} -result {} +test canvas-10.13 {more long tag searches; Bug 2931374} -setup { + catch {destroy .c} + canvas .c +} -body { + .c find withtag {(A&&B&&C&&D)&&area&&!text} + # memory errors on failure +} -cleanup { + destroy .c +} -result {} -test canvas-11.1 {canvas poly fill check, bug 5783} { - # This would crash in 8.3.0 and 8.3.1 +test canvas-11.1 {canvas poly fill check, bug 5783} -setup { destroy .c pack [canvas .c] +} -body { + # This would crash in 8.3.0 and 8.3.1 .c create polygon 0 0 100 100 200 50 \ -fill {} -stipple gray50 -outline black -} 1 -test canvas-11.2 {canvas poly overlap fill check, bug 226357} { +} -result 1 +test canvas-11.2 {canvas poly overlap fill check, bug 226357} -setup { destroy .c pack [canvas .c] +} -body { set result {} .c create poly 30 30 90 90 30 90 90 30 lappend result [.c find over 40 40 45 45]; # rect region inc. edge @@ -379,7 +402,7 @@ test canvas-11.2 {canvas poly overlap fill check, bug 226357} { lappend result [.c find over 45 50 45 50]; # outside poly .c itemconfig 1 -width 8 lappend result [.c find over 45 50 45 50]; # outside poly -} {1 1 {} 1 {} 1 1 {} 1 {} 1} +} -result {1 1 {} 1 {} 1 1 {} 1 {} 1} test canvas-11.3 {canvas poly dchars, bug 3291543} { # This would crash destroy .c @@ -389,25 +412,27 @@ test canvas-11.3 {canvas poly dchars, bug 3291543} { .c coords 1 } {} -test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} { +test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} -setup { destroy .c pack [canvas .c] +} -body { set qx [expr {1.+1.}] # qx has type double and no string representation .c scale all $qx 0 1. 1. # qx has now type MMRep and no string representation list $qx [string length $qx] -} {2.0 3} -test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} { +} -result {2.0 3} +test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup { destroy .c pack [canvas .c] +} -body { set val 10 incr val # qx has type double and no string representation .c scale all $val 0 1 1 # qx has now type MMRep and no string representation incr val -} {12} +} -result 12 proc kill_canvas {w} { destroy $w @@ -433,55 +458,87 @@ test canvas-13.1 {canvas delete during event, SF bug-228024} { set ::x } okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok -test canvas-14.1 {canvas scan SF bug 581560} { - destroy .c; canvas .c - list [catch {.c scan} msg] $msg -} {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} -test canvas-14.2 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan bogus} msg] $msg -} {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} -test canvas-14.3 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan mark} msg] $msg -} {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} -test canvas-14.4 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan mark 10 10} msg] $msg -} {0 {}} -test canvas-14.5 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan mark 10 10 5} msg] $msg -} {1 {wrong # args: should be ".c scan mark x y"}} -test canvas-14.6 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan dragto 10 10 5} msg] $msg -} {0 {}} +test canvas-14.1 {canvas scan SF bug 581560} -setup { + destroy .c + canvas .c +} -body { + .c scan +} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +test canvas-14.2 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan bogus +} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +test canvas-14.3 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan mark +} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +test canvas-14.4 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan mark 10 10 +} -result {} +test canvas-14.5 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan mark 10 10 5 +} -returnCodes error -result {wrong # args: should be ".c scan mark x y"} +test canvas-14.6 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan dragto 10 10 5 +} -result {} set i 0 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" { - 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" { - destroy .c; canvas .c - list [catch {.c create $type 0} msg] \ - [string match "wrong # coordinates: expected*" $msg] - } {1 1} + incr i + test canvas-15.$i "basic types check: $type requires coords" -setup { + destroy .c + canvas .c + } -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 + } -match glob -body { + .c create $type 0 + } -returnCodes error -result "wrong # coordinates: expected*" } -test canvas-16.1 {arc coords check} { - destroy .c; canvas .c +test canvas-16.1 {arc coords check} -setup { + destroy .c + canvas .c +} -body { set id [.c create arc {0 10 20 30} -start 33] .c itemcget $id -start -} {33.0} +} -result {33.0} + +test canvas-17.1 {default smooth method handling} -setup { + destroy .c + canvas .c +} -body { + set id [.c create line {0 0 1 1 2 2 3 3 4 4 5 5 6 6}] + set result [.c itemcget $id -smooth] + foreach smoother {yes 1 bezier raw r b} { + .c itemconfigure $id -smooth $smoother + lappend result [.c itemcget $id -smooth] + } + set result +} -result {0 true true true raw raw true} destroy .c # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/choosedir.test b/tests/choosedir.test index 94dbf90..01a319f 100644 --- a/tests/choosedir.test +++ b/tests/choosedir.test @@ -6,14 +6,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::makeDirectory - #---------------------------------------------------------------------- # # Procedures needed by this test file @@ -83,32 +78,31 @@ proc SendButtonPress {parent btn type} { # #---------------------------------------------------------------------- # Make a dir for us to rely on for tests -makeDirectory choosedirTest -set dir [pwd] +set real [makeDirectory choosedirTest] +set dir [file dirname $real] set fake [file join $dir non-existant] -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" unix { list [catch {tk_chooseDirectory $opt} msg] $msg } [list 1 "value for \"$opt\" missing"] } -test choosedir-1.2 "tk_chooseDirectory command" unixOnly { +test choosedir-1.2 "tk_chooseDirectory command" unix { list [catch {tk_chooseDirectory -foo bar} msg] $msg } [list 1 "bad option \"-foo\": must be -initialdir, -mustexist, -parent, or -title"] -test choosedir-1.3 "tk_chooseDirectory command" unixOnly { +test choosedir-1.3 "tk_chooseDirectory command" unix { list [catch {tk_chooseDirectory -parent foo.bar} msg] $msg } {1 {bad window path name "foo.bar"}} -test choosedir-2.1 "tk_chooseDirectory command, cancel gives null" {unixOnly} { +test choosedir-2.1 "tk_chooseDirectory command, cancel gives null" {unix notAqua} { ToPressButton $parent cancel tk_chooseDirectory -title "Press Cancel" -parent $parent } "" -test choosedir-3.1 "tk_chooseDirectory -mustexist 1" {unixOnly} { +test choosedir-3.1 "tk_chooseDirectory -mustexist 1" {unix notAqua} { # first enter a bogus dirname, then enter a real one. ToEnterDirsByKey $parent [list $fake $real $real] set result [tk_chooseDirectory \ @@ -116,23 +110,23 @@ test choosedir-3.1 "tk_chooseDirectory -mustexist 1" {unixOnly} { -parent $parent -mustexist 1] set result } $real -test choosedir-3.2 "tk_chooseDirectory -mustexist 0" {unixOnly} { +test choosedir-3.2 "tk_chooseDirectory -mustexist 0" {unix notAqua} { ToEnterDirsByKey $parent [list $fake $fake] tk_chooseDirectory -title "Enter \"$fake\", press OK" \ -parent $parent -mustexist 0 } $fake -test choosedir-4.1 "tk_chooseDirectory command, initialdir" {unixOnly} { +test choosedir-4.1 "tk_chooseDirectory command, initialdir" {unix notAqua} { ToPressButton $parent ok tk_chooseDirectory -title "Press Ok" -parent $parent -initialdir $real } $real -test choosedir-4.2 "tk_chooseDirectory command, initialdir" {unixOnly} { +test choosedir-4.2 "tk_chooseDirectory command, initialdir" {unix notAqua} { ToEnterDirsByKey $parent [list $fake $fake] tk_chooseDirectory \ -title "Enter \"$fake\" and press Ok" \ -parent $parent -initialdir $real } $fake -test choosedir-4.3 "tk_chooseDirectory, -initialdir {}" {unixOnly} { +test choosedir-4.3 "tk_chooseDirectory, -initialdir {}" {unix notAqua} { catch {unset ::tk::dialog::file::__tk_choosedir} ToPressButton $parent ok tk_chooseDirectory \ @@ -140,12 +134,13 @@ test choosedir-4.3 "tk_chooseDirectory, -initialdir {}" {unixOnly} { -parent $parent -initialdir "" } [pwd] -test choosedir-5.1 "tk_chooseDirectory, handles {} entry text" {unixOnly} { +test choosedir-5.1 "tk_chooseDirectory, handles {} entry text" {unix notAqua} { ToEnterDirsByKey $parent [list "" $real $real] tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \ -parent $parent } $real # cleanup -::tcltest::cleanupTests +removeDirectory choosedirTest +cleanupTests return diff --git a/tests/clipboard.test b/tests/clipboard.test index e84a820..37e45a3 100644 --- a/tests/clipboard.test +++ b/tests/clipboard.test @@ -12,10 +12,7 @@ # package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # set up a very large buffer to test INCR retrievals @@ -164,14 +161,14 @@ test clipboard-6.1 {Tk_ClipboardAppend procedure} { clipboard get } msg] $msg } {0 {first chunk second chunk}} -test clipboard-6.2 {Tk_ClipboardAppend procedure} {unixOnly} { +test clipboard-6.2 {Tk_ClipboardAppend procedure} unix { setupbg clipboard clear clipboard append -f INTEGER -t TEST "16" set result [dobg {clipboard get TEST}] cleanupbg set result -} {0x10} +} {0x10 } test clipboard-6.3 {Tk_ClipboardAppend procedure} { clipboard clear clipboard append -f INTEGER -t TEST "16" @@ -243,18 +240,5 @@ test clipboard-7.16 {Tk_ClipboardCmd procedure} { } {0 {} -type} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/clrpick.test b/tests/clrpick.test index cd4907a..8b3769e 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -6,12 +6,43 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands +if {[testConstraint defaultPseudocolor8]} { + # let's soak up a bunch of colors...so that + # machines with small color palettes still fail. + # some tests will be skipped if there are no more colors + set numcolors 32 + testConstraint colorsLeftover 1 + set i 0 + canvas .c + pack .c -expand 1 -fill both + while {$i<$numcolors} { + set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]] + .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color + incr i + } + set i 0 + while {$i<$numcolors} { + set color [.c itemcget $i -fill] + if {$color != ""} { + foreach {r g b} [winfo rgb . $color] {} + set r [expr $r/256] + set g [expr $g/256] + set b [expr $b/256] + if {"$color" != "#[format %02x%02x%02x $r $g $b]"} { + testConstraint colorsLeftover 0 + } + } + .c delete $i + incr i + } + destroy .c +} else { + testConstraint colorsLeftover 0 +} + test clrpick-1.1 {tk_chooseColor command} { list [catch {tk_chooseColor -foo} msg] $msg } {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} @@ -21,38 +52,30 @@ 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" } } test clrpick-1.3 {tk_chooseColor command} { list [catch {tk_chooseColor -foo bar} msg] $msg } {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} - test clrpick-1.4 {tk_chooseColor command} { list [catch {tk_chooseColor -initialcolor} msg] $msg } {1 {value for "-initialcolor" missing}} - test clrpick-1.5 {tk_chooseColor command} { list [catch {tk_chooseColor -parent foo.bar} msg] $msg } {1 {bad window path name "foo.bar"}} - test clrpick-1.6 {tk_chooseColor command} { list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg } {1 {unknown color name "badbadbaadcolor"}} - 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 @@ -130,37 +153,6 @@ set verylongstring $verylongstring$verylongstring #set verylongstring $verylongstring$verylongstring #set verylongstring $verylongstring$verylongstring -# let's soak up a bunch of colors...so that -# machines with small color palettes still fail. -# some tests will be skipped if there are no more colors -set numcolors 32 -testConstraint colorsLeftover 1 -set i 0 -canvas .c -pack .c -expand 1 -fill both -while {$i<$numcolors} { - set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]] - .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color - incr i -} -set i 0 -while {$i<$numcolors} { - set color [.c itemcget $i -fill] - if {$color != ""} { - foreach {r g b} [winfo rgb . $color] {} - set r [expr $r/256] - set g [expr $g/256] - set b [expr $b/256] - if {"$color" != "#[format %02x%02x%02x $r $g $b]"} { - testConstraint colorsLeftover 0 - } - } - .c delete $i - incr i -} - -destroy .c - set color #404040 test clrpick-2.1 {tk_chooseColor command} \ {nonUnixUserInteraction colorsLeftover} { @@ -168,25 +160,18 @@ test clrpick-2.1 {tk_chooseColor command} \ tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \ -parent $parent } "$color" - set color #808040 test clrpick-2.2 {tk_chooseColor command} \ {nonUnixUserInteraction colorsLeftover} { - if {$tcl_platform(platform) == "macintosh"} { - set colors "32768 32768 16384" - } else { - set colors "128 128 64" - } + set colors "128 128 64" ToChooseColorByKey $parent 128 128 64 tk_chooseColor -parent $parent -title "choose $colors" } "$color" - test clrpick-2.3 {tk_chooseColor command} \ {nonUnixUserInteraction colorsLeftover} { ToPressButton $parent ok tk_chooseColor -parent $parent -title "Press OK" } "$color" - test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} { ToPressButton $parent cancel tk_chooseColor -parent $parent -title "Press Cancel" @@ -204,7 +189,7 @@ test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} { tk_chooseColor -parent $parent -title "Press Cancel" } "" -test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} unixOnly { +test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} {unix notAqua} { after 50 {set ::scr [winfo screen .__tk__color]} ToPressButton $parent cancel tk_chooseColor -parent $parent @@ -212,5 +197,5 @@ test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} unixOnly { } [winfo screen $parent] # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/cmds.test b/tests/cmds.test index 8cf81e6..f630209 100644 --- a/tests/cmds.test +++ b/tests/cmds.test @@ -6,10 +6,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands update @@ -41,18 +38,5 @@ test cmds-1.5 {tkwait visibility, window gets deleted} { } {1 {window ".f.b" was deleted before its visibility changed} deleted} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/color.test b/tests/color.test index 27ec152..6b31df7 100644 --- a/tests/color.test +++ b/tests/color.test @@ -6,14 +6,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint testcolor [llength [info commands testcolor]] - # cname -- # Returns a proper name for a color, given its intensities. # @@ -270,5 +265,5 @@ test color-4.1 {FreeColorObjProc} colorsFree { destroy .t # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/config.test b/tests/config.test index 1f19ee6..0d1e0e1 100644 --- a/tests/config.test +++ b/tests/config.test @@ -7,14 +7,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint testobjconfig [llength [info commands testobjconfig]] - proc killTables {} { # Note: it's important to delete chain2 before chain1, because # chain2 depends on chain1. If chain1 is deleted first, the @@ -891,5 +886,5 @@ deleteWindows if {[testConstraint testobjconfig]} { killTables } -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/constraints.tcl b/tests/constraints.tcl index f131ff8..843ee4d 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -23,10 +23,25 @@ package require tcltest 2.1 namespace eval tk { namespace eval test { + + namespace export loadTkCommand + proc loadTkCommand {} { + set tklib {} + foreach pair [info loaded {}] { + foreach {lib pfx} $pair break + if {$pfx eq "Tk"} { + set tklib $lib + break + } + } + return [list load $tklib Tk] + } + namespace eval bg { # Manage a background process. # Replace with slave interp or thread? namespace import ::tcltest::interpreter + namespace import ::tk::test::loadTkCommand namespace export setup cleanup do proc cleanup {} { @@ -52,6 +67,8 @@ namespace eval tk { error "unexpected output from\ background process: \"$data\"" } + puts $fd [loadTkCommand] + flush $fd fileevent $fd readable [namespace code Ready] } proc Ready {} { @@ -129,16 +146,40 @@ namespace import -force tk::test::* namespace import -force tcltest::testConstraint testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}] testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}] +testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}] testConstraint userInteraction 0 -testConstraint nonUnixUserInteraction [expr {[testConstraint userInteraction] - || [testConstraint unix]}] -testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)] -testConstraint noExceed [expr {![testConstraint unix] - || [catch {font actual "\{xyz"}]}] +testConstraint nonUnixUserInteraction [expr { + [testConstraint userInteraction] || + ([testConstraint unix] && [testConstraint notAqua]) +}] +testConstraint haveDISPLAY [info exists env(DISPLAY)] +testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)] +testConstraint noExceed [expr { + ![testConstraint unix] || [catch {font actual "\{xyz"}] +}] + +# constraints for testing facilities defined in the tktest executable... testConstraint testImageType [expr {[lsearch [image types] test] >= 0}] -testConstraint testembed [llength [info commands testembed]] -testConstraint testwrapper [llength [info commands testwrapper]] -testConstraint testfont [llength [info commands testfont]] +testConstraint testOldImageType [expr {[lsearch [image types] oldtest] >= 0}] +testConstraint testbitmap [llength [info commands testbitmap]] +testConstraint testborder [llength [info commands testborder]] +testConstraint testcbind [llength [info commands testcbind]] +testConstraint testclipboard [llength [info commands testclipboard]] +testConstraint testcolor [llength [info commands testcolor]] +testConstraint testcursor [llength [info commands testcursor]] +testConstraint testembed [llength [info commands testembed]] +testConstraint testfont [llength [info commands testfont]] +testConstraint testmakeexist [llength [info commands testmakeexist]] +testConstraint testmenubar [llength [info commands testmenubar]] +testConstraint testmenubar [llength [info commands testmenubar]] +testConstraint testmetrics [llength [info commands testmetrics]] +testConstraint testobjconfig [llength [info commands testobjconfig]] +testConstraint testsend [llength [info commands testsend]] +testConstraint testtext [llength [info commands testtext]] +testConstraint testwinevent [llength [info commands testwinevent]] +testConstraint testwrapper [llength [info commands testwrapper]] + +# constraint to see what sort of fonts are available testConstraint fonts 1 destroy .e entry .e -width 0 -font {Helvetica -12} -bd 1 @@ -157,11 +198,28 @@ destroy .t if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} { testConstraint fonts 0 } -testConstraint pseudocolor8 [expr {([catch { - toplevel .t -visual {pseudocolor 8} -colormap new - }] == 0) && ([winfo depth .t] == 8)}] +testConstraint textfonts [expr { + [testConstraint fonts] || $tcl_platform(platform) eq "windows" +}] + +# constraints for the visuals available.. +testConstraint pseudocolor8 [expr { + ([catch { + toplevel .t -visual {pseudocolor 8} -colormap new + }] == 0) && ([winfo depth .t] == 8) +}] destroy .t -testConstraint haveTruecolor24 [expr {[lsearch [winfo visualsavailable .] {truecolor 24}] != -1}] +testConstraint haveTruecolor24 [expr { + [lsearch -exact [winfo visualsavailable .] {truecolor 24}] >= 0 +}] +testConstraint haveGrayscale8 [expr { + [lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0 +}] +testConstraint defaultPseudocolor8 [expr { + ([winfo visual .] eq "pseudocolor") && ([winfo depth .] == 8) +}] + +# constraint based on whether our display is secure setupbg set app [dobg {tk appname}] testConstraint secureserver 0 @@ -177,6 +235,14 @@ cleanupbg eval tcltest::configure $argv namespace import -force tcltest::test +namespace import -force tcltest::makeFile +namespace import -force tcltest::removeFile +namespace import -force tcltest::makeDirectory +namespace import -force tcltest::removeDirectory +namespace import -force tcltest::interpreter +namespace import -force tcltest::testsDirectory +namespace import -force tcltest::cleanupTests +namespace import -force tcltest::bytestring deleteWindows wm geometry . {} diff --git a/tests/cursor.test b/tests/cursor.test index 3624b62..539e933 100644 --- a/tests/cursor.test +++ b/tests/cursor.test @@ -7,14 +7,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint testcursor [llength [info commands testcursor]] - test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} { set x watch lindex $x 0 @@ -79,19 +74,19 @@ set wincur(data_octal) { } set wincur(data_binary) {} foreach wincur(num) $wincur(data_octal) { - append wincur(data_binary) [binary format c 0$wincur(num)] + append wincur(data_binary) [binary format c [scan $wincur(num) %o]] } -set wincur(dir) [::tcltest::makeDirectory {dir with spaces}] -set wincur(file) [::tcltest::makeFile $wincur(data_binary) "test file.cur" $wincur(dir)] -test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} {pcOnly} { +set wincur(dir) [makeDirectory {dir with spaces}] +set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)] +test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} win { destroy .b1 button .b1 -cursor [list @$wincur(file)] } {.b1} -test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} {pcOnly} { +test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} win { destroy .b1 button .b1 -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}] } {.b1} -::tcltest::removeDirectory $wincur(dir) +removeDirectory $wincur(dir) unset wincur test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} { @@ -132,157 +127,187 @@ 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.69 top_right_corner + cursor-6.70 top_side + cursor-6.71 top_tee + cursor-6.72 trek + cursor-6.73 ul_angle + cursor-6.74 umbrella + cursor-6.75 ur_angle + cursor-6.76 watch + cursor-6.77 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 + +# Test cursor named "none", it is not defined in +# the X cursor table. It is defined in a Tk specific +# table of named cursors and should be available on +# all platforms. + +test cursor-6.80 {} -setup { + button .b -text CButton +} -body { + .b configure -cursor none + .b cget -cursor +} -cleanup { + destroy .b +} -result none + +test cursor-6.81 {} -setup { + button .b -text CButton +} -body { + .b configure -cursor none + .b configure -cursor {} + .b cget -cursor +} -cleanup { + destroy .b +} -result {} + +test cursor-6.82 {} -setup { + button .b -text CButton +} -body { + .b configure -cursor none + .b configure -cursor {} + .b configure -cursor none + .b cget -cursor +} -cleanup { + destroy .b +} -result none + +test cursor-6.83 {} -setup { + button .b -text CButton +} -body { + # Setting fg and bg does nothing for the none cursor + # because it displays no fg or bg pixels. + set results [list] + .b configure -cursor none + lappend results [.b cget -cursor] + .b configure -cursor {none blue} + lappend results [.b cget -cursor] + .b configure -cursor {none blue green} + lappend results [.b cget -cursor] + .b configure -cursor {} + lappend results [.b cget -cursor] + set results +} -cleanup { + destroy .b + unset results +} -result {none {none blue} {none blue green} {}} # ------------------------------------------------------------------------- # 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 -} { - 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 -} -unset n -# ------------------------------------------------------------------------- -# Check the Mac specific cursors -set n 0 -foreach cursor { - text - cross-hair +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-8.$n {check cursor $cursor} \ - -constraints {macOnly} \ - -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 win -setup { + button .b -text $cursor + } -body { + .b configure -cursor $cursor + } -cleanup { + destroy .b + } -result {} } -unset n # ------------------------------------------------------------------------- destroy .t # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/dialog.test b/tests/dialog.test index 53c10c0..f47296e 100644 --- a/tests/dialog.test +++ b/tests/dialog.test @@ -2,15 +2,12 @@ # It is organized in the standard fashion for Tcl tests. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -test dialog-1.1 {tk_dialog command} { +test dialog-1.1 {tk_dialog command} -body { list [catch {tk_dialog} msg] $msg -} {1 {wrong # args: should be "tk_dialog w title text bitmap default args"}} +} -match glob -result {1 {wrong # args: should be "tk_dialog w title text bitmap default *"}} test dialog-1.2 {tk_dialog command} { list [catch {tk_dialog foo foo foo foo foo} msg] $msg } {1 {bad window path name "foo"}} @@ -57,5 +54,5 @@ test dialog-2.2 {tk_dialog operation} { set res } {-1} -tcltest::cleanupTests +cleanupTests return diff --git a/tests/earth.gif b/tests/earth.gif Binary files differnew file mode 100644 index 0000000..2c229eb --- /dev/null +++ b/tests/earth.gif diff --git a/tests/embed.test b/tests/embed.test index d3c0753..bac2675 100644 --- a/tests/embed.test +++ b/tests/embed.test @@ -5,12 +5,11 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands +global tcl_platform + test embed-1.1 {TkpUseWindow procedure, bad window identifier} { deleteWindows list [catch {toplevel .t -use xyz} msg] $msg @@ -29,21 +28,43 @@ test embed-1.3 {CreateFrame procedure, both -use and -container 1} msg] $msg } {1 {A window cannot have both the -use and the -container option set.}} -test embed-1.4 {TkpUseWindow procedure, -container must be set} { +if {$tcl_platform(platform) == "windows"} { + +# testing window embedding for Windows platform + +test embed-1.4.win {TkpUseWindow procedure, -container must be set} { + deleteWindows + toplevel .container + list [catch {toplevel .embd -use [winfo id .container]} err] $err +} {1 {the window to use is not a Tk container}} + +test embed-1.5.win {TkpUseWindow procedure, -container must be set} { + deleteWindows + frame .container + list [catch {toplevel .embd -use [winfo id .container]} err] $err +} {1 {the window to use is not a Tk container}} + +} else { + +# testing window embedding for other platforms + +test embed-1.4.nonwin {TkpUseWindow procedure, -container must be set} { deleteWindows toplevel .container list [catch {toplevel .embd -use [winfo id .container]} err] $err } {1 {window ".container" doesn't have -container option set}} -test embed-1.5 {TkpUseWindow procedure, -container must be set} { +test embed-1.5.nonwin {TkpUseWindow procedure, -container must be set} { deleteWindows frame .container list [catch {toplevel .embd -use [winfo id .container]} err] $err } {1 {window ".container" doesn't have -container option set}} +} # FIXME: test cases common to unixEmbed.test and macEmbed.test should # be moved here. -tcltest::cleanupTests +cleanupTests return + diff --git a/tests/entry.test b/tests/entry.test index 9c55483..ffdbf45 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands proc scroll args { @@ -82,16 +79,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 @@ -250,7 +247,7 @@ test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} { .e configure -state normal .e get } {01234567890} -test entry-3.27 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.26a {EntryWidgetCmd procedure, "delete" widget command} { .e delete 0 end .e insert end "01234567890" .e configure -state readonly @@ -314,7 +311,7 @@ test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} { .e configure -state normal .e get } {01234567890} -test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.40a {EntryWidgetCmd procedure, "insert" widget command} { .e delete 0 end .e insert end "01234567890" .e configure -state readonly @@ -451,7 +448,7 @@ test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} { .e configure -state normal list [.e index sel.first] [.e index sel.last] } {0 10} -test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} { +test entry-3.64a {EntryWidgetCmd procedure, "selection" widget command} { .e delete 0 end .e insert end 0123456789 .e selection range 0 end @@ -463,13 +460,13 @@ test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} { .e delete 0 end .e insert end "This is quite a long text string, so long that it " .e insert end "runs off the end of the window quite a bit." -test entry-3.64 {EntryWidgetCmd procedure, "selection to" widget command} { +test entry-3.64b {EntryWidgetCmd procedure, "selection to" widget command} { list [catch {.e select to 2 3} msg] $msg } {1 {wrong # args: should be ".e selection to index"}} test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 5 - .e xview -} {0.0537634 0.268817} + format {%.7f %.7f} {*}[.e xview] +} {0.0537634 0.2688172} test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview gorp} msg] $msg } {1 {bad entry index "gorp"}} @@ -477,7 +474,7 @@ test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 0 .e icursor 10 .e xview insert - .e xview + format {%.6f %.6f} {*}[.e xview] } {0.107527 0.322581} test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview moveto foo bar} msg] $msg @@ -487,8 +484,8 @@ test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} { } {1 {expected floating-point number but got "foo"}} test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} { .e xview moveto 0.5 - .e xview -} {0.505376 0.72043} + format {%.6f %.6f} {*}[.e xview] +} {0.505376 0.720430} test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview scroll 24} msg] $msg } {1 {wrong # args: should be ".e xview scroll number units|pages"}} @@ -498,13 +495,13 @@ test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} { test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} { .e xview moveto 0 .e xview scroll 1 pages - .e xview + format {%.6f %.6f} {*}[.e xview] } {0.193548 0.408602} test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} { .e xview moveto .9 update .e xview scroll -2 p - .e xview + format {%.6f %.6f} {*}[.e xview] } {0.397849 0.612903} test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 30 @@ -542,12 +539,12 @@ test entry-3.81 {EntryWidgetCmd procedure, "xview" widget command} { set x {} .e xview moveto .1 - lappend x [lindex [.e xview] 0] + lappend x [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .11 - lappend x [lindex [.e xview] 0] + lappend x [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .12 - lappend x [lindex [.e xview] 0] -} {0.0957447 0.106383 0.117021} + lappend x [format {%.6f} [lindex [.e xview] 0]] +} {0.095745 0.106383 0.117021} test entry-3.82 {EntryWidgetCmd procedure} { list [catch {.e gorp} msg] $msg } {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}} @@ -639,8 +636,8 @@ test entry-5.7 {ConfigureEntry procedure} { .e insert end "01234567890" update .e configure -width 5 - set scrollInfo -} {0 0.363636} + format {%.6f %.6f} {*}$scrollInfo +} {0.000000 0.363636} test entry-5.8 {ConfigureEntry procedure} {fonts} { catch {destroy .e} entry .e -width 0 @@ -674,7 +671,7 @@ test entry-5.11 {ConfigureEntry procedure} { pack [entry .e -font {{open look glyph}}] .e scan dragto 30 update -} {} +} {} # No tests for DisplayEntry. @@ -754,7 +751,7 @@ test entry-6.9 {EntryComputeGeometry procedure} {fonts} { update list [winfo reqwidth .e] [winfo reqheight .e] } {25 39} -test entry-6.10 {EntryComputeGeometry procedure} {unixOnly fonts} { +test entry-6.10 {EntryComputeGeometry procedure} {unix fonts} { catch {destroy .e} entry .e -bd 1 -relief raised -width 0 -show . .e insert 0 12345 @@ -766,7 +763,7 @@ test entry-6.10 {EntryComputeGeometry procedure} {unixOnly fonts} { .e configure -show "" lappend x [winfo reqwidth .e] } {23 53 43} -test entry-6.11 {EntryComputeGeometry procedure} {pcOnly} { +test entry-6.11 {EntryComputeGeometry procedure} win { catch {destroy .e} entry .e -bd 1 -relief raised -width 0 -show . -font {helvetica 12} .e insert 0 12345 @@ -791,15 +788,15 @@ test entry-7.1 {InsertChars procedure} { .e insert 0 abcde .e insert 2 XXX update - list [.e get] $contents $scrollInfo -} {abXXXcde abXXXcde {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {abXXXcde abXXXcde {0.000000 1.000000}} test entry-7.2 {InsertChars procedure} { .e delete 0 end .e insert 0 abcde .e insert 500 XXX update - list [.e get] $contents $scrollInfo -} {abcdeXXX abcdeXXX {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {abcdeXXX abcdeXXX {0.000000 1.000000}} test entry-7.3 {InsertChars procedure} { .e delete 0 end .e insert 0 0123456789 @@ -885,22 +882,22 @@ test entry-8.1 {DeleteChars procedure} { .e insert 0 abcde .e delete 2 4 update - list [.e get] $contents $scrollInfo -} {abe abe {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {abe abe {0.000000 1.000000}} test entry-8.2 {DeleteChars procedure} { .e delete 0 end .e insert 0 abcde .e delete -2 2 update - list [.e get] $contents $scrollInfo -} {cde cde {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {cde cde {0.000000 1.000000}} test entry-8.3 {DeleteChars procedure} { .e delete 0 end .e insert 0 abcde .e delete 3 1000 update - list [.e get] $contents $scrollInfo -} {abc abc {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {abc abc {0.000000 1.000000}} test entry-8.4 {DeleteChars procedure} { .e delete 0 end .e insert 0 0123456789abcde @@ -1196,26 +1193,26 @@ test entry-13.9 {GetEntryIndex procedure} { list [.e index sel.first] [.e index sel.last] } {1 6} selection clear .e -test entry-13.10 {GetEntryIndex procedure} {unixOnly} { +test entry-13.10 {GetEntryIndex procedure} unix { # On unix, when selection is cleared, entry widget's internal # selection range is reset. list [catch {.e index sel.first} msg] $msg } {1 {selection isn't in widget .e}} -test entry-13.11 {GetEntryIndex procedure} {macOrPc} { +test entry-13.11 {GetEntryIndex procedure} win { # On mac and pc, when selection is cleared, entry widget remembers # last selected range. When selection ownership is restored to # entry, the old range will be rehighlighted. list [catch {selection get}] [.e index sel.first] } {1 1} -test entry-13.12 {GetEntryIndex procedure} {unixOnly} { +test entry-13.12 {GetEntryIndex procedure} unix { list [catch {.e index sbogus} msg] $msg } {1 {selection isn't in widget .e}} -test entry-13.13 {GetEntryIndex procedure} {macOrPc} { +test entry-13.13 {GetEntryIndex procedure} win { list [catch {.e index sbogus} msg] $msg } {1 {bad entry index "sbogus"}} -test entry-13.14 {GetEntryIndex procedure} {macOrPc} { +test entry-13.14 {GetEntryIndex procedure} win { list [catch {selection get}] [catch {.e index sbogus}] } {1 1} test entry-13.15 {GetEntryIndex procedure} { @@ -1314,25 +1311,25 @@ update test entry-16.1 {EntryVisibleRange procedure} {fonts} { .e delete 0 end .e insert 0 ............................. - .e xview -} {0 0.827586} -test entry-15.2 {EntryVisibleRange procedure} {unixOnly fonts} { + format {%.6f %.6f} {*}[.e xview] +} {0.000000 0.827586} +test entry-16.2 {EntryVisibleRange procedure} {unix fonts} { .e configure -show X .e delete 0 end .e insert 0 ............................. - .e xview -} {0 0.275862} -test entry-15.3 {EntryVisibleRange procedure} {pcOnly} { + format {%.6f %.6f} {*}[.e xview] +} {0.000000 0.275862} +test entry-16.3 {EntryVisibleRange procedure} win { .e configure -show . .e delete 0 end .e insert 0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXX - .e xview -} {0 0.827586} + format {%.6f %.6f} {*}[.e xview] +} {0.000000 0.827586} .e configure -show "" -test entry-15.4 {EntryVisibleRange procedure} { +test entry-16.4 {EntryVisibleRange procedure} { .e delete 0 end - .e xview -} {0 1} + format {%.6f %.6f} {*}[.e xview] +} {0.000000 1.000000} catch {destroy .e} entry .e -width 10 -xscrollcommand scroll -font $fixed @@ -1342,21 +1339,21 @@ test entry-17.1 {EntryUpdateScrollbar procedure} { .e delete 0 end .e insert 0 123 update - set scrollInfo -} {0 1} + format {%.6f %.6f} {*}$scrollInfo +} {0.000000 1.000000} test entry-17.2 {EntryUpdateScrollbar procedure} { .e delete 0 end .e insert 0 0123456789abcdef .e xview 3 update - set scrollInfo -} {0.1875 0.8125} + format {%.6f %.6f} {*}$scrollInfo +} {0.187500 0.812500} test entry-17.3 {EntryUpdateScrollbar procedure} { .e delete 0 end .e insert 0 abcdefghijklmnopqrs .e xview 6 update - set scrollInfo + format {%.6f %.6f} {*}$scrollInfo } {0.315789 0.842105} test entry-17.4 {EntryUpdateScrollbar procedure} { destroy .e @@ -1371,7 +1368,7 @@ test entry-17.4 {EntryUpdateScrollbar procedure} { list $x $errorInfo } {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand" while executing -"thisisnotacommand 0 1" +"thisisnotacommand 0.0 1.0" (horizontal scrolling command executed by .e)}} set l [interp hidden] @@ -1631,5 +1628,5 @@ destroy .e option clear # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/event.test b/tests/event.test index f6f30df..fa75610 100644 --- a/tests/event.test +++ b/tests/event.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # XXX This test file is woefully incomplete. Right now it only tests @@ -19,7 +16,7 @@ tcltest::loadTestedCommands # Setup table used to query key events. -proc _init_keypress_lookup { } { +proc _init_keypress_lookup {} { global keypress_lookup scan A %c start @@ -46,43 +43,47 @@ proc _init_keypress_lookup { } { set keypress_lookup($l) $l } + # Most punctuation + array set keypress_lookup { + ! exclam + % percent + & ampersand + ( parenleft + ) parenright + * asterisk + + plus + , comma + - minus + . period + / slash + : colon + < less + = equal + > greater + ? question + @ at + ^ asciicircum + _ underscore + | bar + ~ asciitilde + ' apostrophe + } + # Characters with meaning to Tcl... array set keypress_lookup [list \ - " " space \ - ! exclam \ - \" quotedbl \ - \# numbersign \ - \$ dollar \ - % percent \ - & ampersand \ - ( parenleft \ - ) parenright \ - * asterisk \ - + plus \ - , comma \ - - minus \ - . period \ - / slash \ - : colon \ - \; semicolon \ - < less \ - = equal \ - > greater \ - ? question \ - @ at \ - \[ bracketleft \ - \\ backslash \ - \] bracketright \ - ^ asciicircum \ - _ underscore \ - \{ braceleft \ - | bar \ - \} braceright \ - ~ asciitilde \ - ' apostrophe \ - "\n" Return] + \" quotedbl \ + \# numbersign \ + \$ dollar \ + \; semicolon \ + \[ bracketleft \ + \\ backslash \ + \] bracketright \ + \{ braceleft \ + \} braceright \ + " " space \ + "\n" Return \ + "\t" Tab] } - # Lookup an event in the keypress table. # For example: # Q -> Q @@ -91,7 +92,7 @@ proc _init_keypress_lookup { } { # Delete -> Delete # Escape -> Escape -proc _keypress_lookup { char } { +proc _keypress_lookup {char} { global keypress_lookup if {! [info exists keypress_lookup]} { @@ -109,10 +110,9 @@ proc _keypress_lookup { char } { } } - # Lookup and generate a pair of KeyPress and KeyRelease events -proc _keypress { win key } { +proc _keypress {win key} { set keysym [_keypress_lookup $key] # Force focus to the window before delivering @@ -134,7 +134,7 @@ proc _keypress { win key } { # Call _keypress for each character in the given string -proc _keypress_string { win string } { +proc _keypress_string {win string} { foreach letter [split $string ""] { _keypress $win $letter } @@ -142,7 +142,7 @@ proc _keypress_string { win string } { # Delay script execution for a given amount of time -proc _pause { {msecs 1000} } { +proc _pause {{msecs 1000}} { global _pause if {! [info exists _pause(number)]} { @@ -159,7 +159,7 @@ proc _pause { {msecs 1000} } { # Helper proc to convert index to x y position -proc _text_ind_to_x_y { text ind } { +proc _text_ind_to_x_y {text ind} { set bbox [$text bbox $ind] if {[llength $bbox] != 4} { error "got bbox \{$bbox\} from $text, index $ind" @@ -171,7 +171,7 @@ proc _text_ind_to_x_y { text ind } { # Return selection only if owned by the given widget -proc _get_selection { widget } { +proc _get_selection {widget} { if {[string compare $widget [selection own]] != 0} { return "" } @@ -200,7 +200,6 @@ test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} { destroy .b set x } {destroy} - test event-1.2 {event generate <Alt-z>} { catch {destroy .e} catch {unset ::event12result} @@ -213,9 +212,7 @@ test event-1.2 {event generate <Alt-z>} { set ::event12result } 1 - - -test event-keypress-1.1 { type into entry widget and hit Return } { +test event-2.1(keypress) {type into entry widget and hit Return} { destroy .t set t [toplevel .t] set e [entry $t.e] @@ -226,9 +223,7 @@ test event-keypress-1.1 { type into entry widget and hit Return } { _keypress_string $e HELLO\n list [$e get] $return_binding } {HELLO 1} - - -test event-keypress-1.2 { type into entry widget and then delete some text } { +test event-2.2(keypress) {type into entry widget and then delete some text} { destroy .t set t [toplevel .t] set e [entry $t.e] @@ -239,9 +234,8 @@ test event-keypress-1.2 { type into entry widget and then delete some text } { _keypress $e BackSpace $e get } MEL - -test event-keypress-1.3 { type into entry widget, triple click, - hit Delete key, and then type some more } { +test event-2.3(keypress) {type into entry widget, triple click,\ + hit Delete key, and then type some more} { destroy .t set t [toplevel .t] set e [entry $t.e] @@ -263,9 +257,7 @@ test event-keypress-1.3 { type into entry widget, triple click, _keypress_string $e UP lappend result [$e get] } {JUMP UP} - - -test event-keypress-1.4 { type into text widget and hit Return } { +test event-1.4(keypress) {type into text widget and hit Return} { destroy .t set t [toplevel .t] set e [text $t.e] @@ -276,8 +268,7 @@ test event-keypress-1.4 { type into text widget and hit Return } { _keypress_string $e HELLO\n list [$e get 1.0 end] $return_binding } [list "HELLO\n\n" 1] - -test event-keypress-1.5 { type into text widget and then delete some text } { +test event-2.5(keypress) {type into text widget and then delete some text} { destroy .t set t [toplevel .t] set e [text $t.e] @@ -288,9 +279,8 @@ test event-keypress-1.5 { type into text widget and then delete some text } { _keypress $e BackSpace $e get 1.0 1.end } MEL - -test event-keypress-1.6 { type into text widget, triple click, - hit Delete key, and then type some more } { +test event-2.6(keypress) {type into text widget, triple click,\ + hit Delete key, and then type some more} { destroy .t set t [toplevel .t] set e [text $t.e] @@ -313,10 +303,8 @@ test event-keypress-1.6 { type into text widget, triple click, lappend result [$e get 1.0 1.end] } {JUMP UP} - - -test event-click-drag-1.1 { click and drag in a text widget, this - tests tkTextSelectTo in text.tcl } { +test event-3.1(click-drag) {click and drag in a text widget, this tests\ + tkTextSelectTo in text.tcl} { destroy .t set t [toplevel .t] set e [text $t.e] @@ -379,12 +367,8 @@ test event-click-drag-1.1 { click and drag in a text widget, this lappend result [_get_selection $e] } {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}} - - - - -test event-click-drag-1.2 { click and drag in an entry widget, this - tests tkEntryMouseSelect in entry.tcl } { +test event-3.2(click-drag) {click and drag in an entry widget, this\ + tests tkEntryMouseSelect in entry.tcl} { destroy .t set t [toplevel .t] set e [entry $t.e] @@ -448,10 +432,8 @@ test event-click-drag-1.2 { click and drag in an entry widget, this } {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}} - - -test event-double-click-drag-1.1 { click down, click up, click down again, - then drag in a text widget } { +test event-4.1(double-click-drag) {click down, click up, click down again,\ + then drag in a text widget} { destroy .t set t [toplevel .t] set e [text $t.e] @@ -476,7 +458,7 @@ test event-double-click-drag-1.1 { click down, click up, click down again, set result [list] lappend result [_get_selection $e] - # Insert cursor should be at end of "select" + # Insert cursor should be at beginning of "select" lappend result [$e index insert] # Move mouse one character to the left @@ -516,12 +498,9 @@ test event-double-click-drag-1.1 { click down, click up, click down again, lappend result [$e index insert] set result -} {select 1.11 1.7 select 1.4 { select} {Word select} 1.2} - - - -test event-double-click-drag-1.2 { click down, click up, click down again, - then drag in an entry widget } { +} {select 1.5 1.7 select 1.4 { select} {Word select} 1.2} +test event-4.2(double-click-drag) {click down, click up, click down again,\ + then drag in an entry widget} { destroy .t set t [toplevel .t] set e [entry $t.e] @@ -588,9 +567,8 @@ test event-double-click-drag-1.2 { click down, click up, click down again, set result } {select 11 7 select 4 { select} {Word select} 2} - -test event-triple-click-drag-1.1 { Triple click and drag across lines in - a text widget, this should extend the selection to the new line } { +test event-5.1(triple-click-drag) {Triple click and drag across lines in\ + a text widget, this should extend the selection to the new line} { destroy .t set t [toplevel .t] set e [text $t.e] @@ -647,10 +625,10 @@ test event-triple-click-drag-1.1 { Triple click and drag across lines in } [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \ "LINE ONE\nLINE TWO\nLINE THREE\n"] -test event-button-state-1.1 { button press in a window that is then - destroyed, when the mouse is moved into another window it - should not generate a <B1-motion> event since the mouse - was not pressed down in that window. } { +test event-6.1(button-state) {button press in a window that is then\ + destroyed, when the mouse is moved into another window it\ + should not generate a <B1-motion> event since the mouse\ + was not pressed down in that window} { destroy .t set t [toplevel .t] @@ -663,6 +641,133 @@ test event-button-state-1.1 { button press in a window that is then set motion } nomotion +test event-7.1(double-click) {A double click on a lone character + in a text widget should select that character} { + destroy .t + set t [toplevel .t] + set e [text $t.e] + pack $e + tkwait visibility $e + focus -force $e + _keypress_string $e "On A letter" + + set anchor 1.3 + + # Get x,y coords just inside the left + # and right hand side of the letter A + foreach {x1 y1 width height} [$e bbox $anchor] break + + set middle_y [expr {$y1 + ($height / 2)}] + + set left_x [expr {$x1 + 2}] + set left_y $middle_y + + set right_x [expr {($x1 + $width) - 2}] + set right_y $middle_y + + # Double click near left hand egde of the letter A + + event generate $e <Enter> + event generate $e <ButtonPress-1> -x $left_x -y $left_y + _pause 50 + event generate $e <ButtonRelease-1> -x $left_x -y $left_y + _pause 50 + event generate $e <ButtonPress-1> -x $left_x -y $left_y + _pause 50 + event generate $e <ButtonRelease-1> -x $left_x -y $left_y + _pause 50 + + set result [list] + lappend result [$e index insert] + lappend result [_get_selection $e] + + # Clear selection by clicking at 0,0 + + event generate $e <ButtonPress-1> -x 0 -y 0 + _pause 50 + event generate $e <ButtonRelease-1> -x 0 -y 0 + _pause 50 + + # Double click near right hand edge of the letter A + + event generate $e <ButtonPress-1> -x $right_x -y $right_y + _pause 50 + event generate $e <ButtonRelease-1> -x $right_x -y $right_y + _pause 50 + event generate $e <ButtonPress-1> -x $right_x -y $right_y + _pause 50 + event generate $e <ButtonRelease-1> -x $right_x -y $right_y + _pause 50 + + lappend result [$e index insert] + lappend result [_get_selection $e] + + set result +} {1.3 A 1.3 A} +test event-7.2(double-click) {A double click on a lone character\ + in an entry widget should select that character} {knownBug} { + destroy .t + set t [toplevel .t] + set e [entry $t.e] + pack $e + tkwait visibility $e + focus -force $e + _keypress_string $e "On A letter" + + set anchor 3 + + # Get x,y coords just inside the left + # and right hand side of the letter A + foreach {x1 y1 width height} [$e bbox $anchor] break + + set middle_y [expr {$y1 + ($height / 2)}] + + set left_x [expr {$x1 + 2}] + set left_y $middle_y + + set right_x [expr {($x1 + $width) - 2}] + set right_y $middle_y + + # Double click near left hand egde of the letter A + + event generate $e <Enter> + event generate $e <ButtonPress-1> -x $left_x -y $left_y + _pause 50 + event generate $e <ButtonRelease-1> -x $left_x -y $left_y + _pause 50 + event generate $e <ButtonPress-1> -x $left_x -y $left_y + _pause 50 + event generate $e <ButtonRelease-1> -x $left_x -y $left_y + _pause 50 + + set result [list] + lappend result [$e index insert] + lappend result [_get_selection $e] + + # Clear selection by clicking at 0,0 + + event generate $e <ButtonPress-1> -x 0 -y 0 + _pause 50 + event generate $e <ButtonRelease-1> -x 0 -y 0 + _pause 50 + + # Double click near right hand edge of the letter A + + event generate $e <ButtonPress-1> -x $right_x -y $right_y + _pause 50 + event generate $e <ButtonRelease-1> -x $right_x -y $right_y + _pause 50 + event generate $e <ButtonPress-1> -x $right_x -y $right_y + _pause 50 + event generate $e <ButtonRelease-1> -x $right_x -y $right_y + _pause 50 + + lappend result [$e index insert] + lappend result [_get_selection $e] + + set result +} {3 A 4 A} + # cleanup destroy .t @@ -675,6 +780,5 @@ rename _pause {} rename _text_ind_to_x_y {} rename _get_selection {} -::tcltest::cleanupTests +cleanupTests return - diff --git a/tests/face.xbm b/tests/face.xbm new file mode 100644 index 0000000..03d829f --- /dev/null +++ b/tests/face.xbm @@ -0,0 +1,173 @@ +#define face_width 108 +#define face_height 144 +#define face_x_hot 48 +#define face_y_hot 80 +static char face_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08, 0x09, + 0x20, 0x80, 0x24, 0x05, 0x00, 0x80, 0x08, 0x00, 0x00, 0x00, 0x00, 0x88, + 0x24, 0x20, 0x80, 0x24, 0x00, 0x00, 0x00, 0x10, 0x80, 0x04, 0x00, 0x01, + 0x00, 0x01, 0x40, 0x0a, 0x09, 0x00, 0x92, 0x04, 0x80, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x10, 0x40, 0x12, 0x00, 0x00, 0x10, 0x40, 0x00, 0x00, 0x84, + 0x24, 0x40, 0x22, 0xa8, 0x02, 0x14, 0x84, 0x92, 0x40, 0x42, 0x12, 0x04, + 0x10, 0x00, 0x00, 0x00, 0x00, 0x52, 0x00, 0x52, 0x11, 0x00, 0x12, 0x00, + 0x40, 0x02, 0x00, 0x20, 0x00, 0x08, 0x00, 0xaa, 0x02, 0x54, 0x85, 0x24, + 0x00, 0x10, 0x12, 0x00, 0x00, 0x81, 0x44, 0x00, 0x90, 0x5a, 0x00, 0xea, + 0x1b, 0x00, 0x80, 0x40, 0x40, 0x02, 0x00, 0x08, 0x00, 0x20, 0xa2, 0x05, + 0x8a, 0xb4, 0x6e, 0x45, 0x12, 0x04, 0x08, 0x00, 0x00, 0x00, 0x10, 0x02, + 0xa8, 0x92, 0x00, 0xda, 0x5f, 0x10, 0x00, 0x10, 0xa1, 0x04, 0x20, 0x41, + 0x02, 0x00, 0x5a, 0x25, 0xa0, 0xff, 0xfb, 0x05, 0x41, 0x02, 0x04, 0x00, + 0x00, 0x08, 0x40, 0x80, 0xec, 0x9b, 0xec, 0xfe, 0x7f, 0x01, 0x04, 0x20, + 0x90, 0x02, 0x04, 0x00, 0x08, 0x20, 0xfb, 0x2e, 0xf5, 0xff, 0xff, 0x57, + 0x00, 0x04, 0x02, 0x00, 0x00, 0x20, 0x01, 0xc1, 0x6e, 0xab, 0xfa, 0xff, + 0xff, 0x05, 0x90, 0x20, 0x48, 0x02, 0x00, 0x04, 0x20, 0xa8, 0xdf, 0xb5, + 0xfe, 0xff, 0xff, 0x0b, 0x01, 0x00, 0x01, 0x00, 0x80, 0x80, 0x04, 0xe0, + 0xbb, 0xef, 0xff, 0xff, 0x7f, 0x01, 0x00, 0x04, 0x48, 0x02, 0x00, 0x20, + 0x80, 0xf4, 0x6f, 0xfb, 0xff, 0xff, 0xff, 0x20, 0x90, 0x40, 0x02, 0x00, + 0x00, 0x04, 0x08, 0xb8, 0xf6, 0xff, 0xff, 0xdf, 0xbe, 0x12, 0x45, 0x10, + 0x90, 0x04, 0x90, 0x00, 0x22, 0xfa, 0xff, 0xff, 0xff, 0xbb, 0xd7, 0xe9, + 0x3a, 0x02, 0x02, 0x00, 0x04, 0x90, 0x80, 0xfe, 0xdf, 0xf6, 0xb7, 0xef, + 0xbe, 0x56, 0x57, 0x40, 0x48, 0x09, 0x00, 0x04, 0x00, 0xfa, 0xf5, 0xdf, + 0xed, 0x5a, 0xd5, 0xea, 0xbd, 0x09, 0x00, 0x00, 0x40, 0x00, 0x92, 0xfe, + 0xbf, 0x7d, 0xb7, 0x6a, 0x55, 0xbf, 0xf7, 0x02, 0x11, 0x01, 0x00, 0x91, + 0x00, 0xff, 0xff, 0xaf, 0x55, 0x55, 0x5b, 0xeb, 0xef, 0x22, 0x04, 0x04, + 0x04, 0x00, 0xa4, 0xff, 0xf7, 0xad, 0xaa, 0xaa, 0xaa, 0xbe, 0xfe, 0x03, + 0x20, 0x00, 0x10, 0x44, 0x80, 0xff, 0x7f, 0x55, 0x12, 0x91, 0x2a, 0xeb, + 0xbf, 0x0b, 0x82, 0x02, 0x00, 0x00, 0xd1, 0x7f, 0xdf, 0xa2, 0xa4, 0x54, + 0x55, 0xfd, 0xfd, 0x47, 0x08, 0x08, 0x00, 0x21, 0xe4, 0xff, 0x37, 0x11, + 0x09, 0xa5, 0xaa, 0xb6, 0xff, 0x0d, 0x80, 0x00, 0x00, 0x04, 0xd0, 0xff, + 0x4f, 0x44, 0x20, 0x48, 0x55, 0xfb, 0xff, 0x27, 0x11, 0x02, 0x40, 0x40, + 0xe2, 0xfb, 0x15, 0x11, 0x4a, 0x55, 0x4a, 0x7d, 0xf7, 0x0f, 0x00, 0x00, + 0x04, 0x08, 0xf8, 0xdf, 0x52, 0x44, 0x01, 0x52, 0xb5, 0xfa, 0xff, 0x0f, + 0x49, 0x02, 0x00, 0x02, 0xe9, 0xf6, 0x0a, 0x11, 0xa4, 0x88, 0x4a, 0x6d, + 0xff, 0x5f, 0x00, 0x00, 0x10, 0x20, 0xf0, 0x2f, 0x21, 0x44, 0x10, 0x52, + 0xb5, 0xfa, 0xff, 0x0f, 0x44, 0x04, 0x80, 0x08, 0xf8, 0xab, 0x8a, 0x00, + 0x81, 0xa4, 0xd4, 0xd6, 0xfe, 0x2f, 0x00, 0x00, 0x04, 0x40, 0xb5, 0x2d, + 0x21, 0x08, 0x04, 0x90, 0xaa, 0xfa, 0xff, 0x1f, 0x11, 0x01, 0x00, 0x04, + 0xf0, 0x57, 0x0a, 0x22, 0x40, 0x4a, 0xda, 0x5e, 0xfb, 0x1f, 0x40, 0x00, + 0x40, 0x20, 0xba, 0x95, 0x90, 0x00, 0x01, 0xa0, 0xaa, 0xea, 0xff, 0x5f, + 0x02, 0x02, 0x00, 0x01, 0xe8, 0x57, 0x05, 0x00, 0x00, 0x12, 0xd5, 0xfe, + 0xfd, 0x1f, 0x48, 0x00, 0x04, 0x48, 0x7a, 0x95, 0x08, 0x02, 0x10, 0x40, + 0xaa, 0x55, 0xf7, 0x1f, 0x00, 0x09, 0x20, 0x00, 0xf8, 0x57, 0x22, 0x10, + 0x00, 0x28, 0xa9, 0xfa, 0xff, 0x5f, 0x02, 0x00, 0x00, 0x49, 0xdd, 0x29, + 0x01, 0x00, 0x80, 0x80, 0xaa, 0xd7, 0xff, 0x0f, 0x10, 0x00, 0x08, 0x00, + 0xf8, 0x96, 0x08, 0x00, 0x00, 0x20, 0x54, 0xfa, 0xee, 0x3f, 0x81, 0x04, + 0x40, 0x24, 0xfe, 0x55, 0x82, 0x00, 0x00, 0x82, 0xd2, 0xad, 0xff, 0x0f, + 0x08, 0x00, 0x04, 0x80, 0x6c, 0x97, 0x00, 0x00, 0x02, 0x20, 0xa9, 0xf6, + 0xdf, 0x5f, 0x00, 0x02, 0x20, 0x09, 0xfa, 0x49, 0x12, 0x00, 0x20, 0x84, + 0x54, 0xdb, 0xfe, 0x1f, 0x91, 0x00, 0x00, 0x00, 0xf8, 0x2b, 0x00, 0x20, + 0x00, 0x40, 0xa4, 0xf6, 0xbb, 0x1f, 0x04, 0x00, 0x44, 0x92, 0x7e, 0x95, + 0x02, 0x00, 0x00, 0x89, 0xaa, 0xdd, 0xff, 0x1f, 0x20, 0x09, 0x10, 0x00, + 0xf4, 0x57, 0x20, 0x01, 0x08, 0x20, 0xa9, 0x76, 0xff, 0x5f, 0x02, 0x00, + 0x00, 0x21, 0xfc, 0x4a, 0x05, 0x00, 0x01, 0x80, 0x54, 0xdb, 0xff, 0x1e, + 0x08, 0x02, 0x04, 0x08, 0xf9, 0x2b, 0x00, 0x00, 0x40, 0x28, 0xd2, 0xf6, + 0xff, 0xbf, 0x80, 0x00, 0x90, 0x00, 0xbc, 0x92, 0x08, 0x10, 0x00, 0x82, + 0x54, 0xdb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x44, 0xf9, 0x55, 0x02, 0x01, + 0x00, 0x20, 0xaa, 0xbd, 0xfd, 0x3f, 0x08, 0x04, 0x04, 0x10, 0xf4, 0x2a, + 0x01, 0x00, 0x22, 0x80, 0xd4, 0xf6, 0xff, 0x5f, 0x82, 0x00, 0x40, 0x02, + 0xf8, 0x55, 0x20, 0x00, 0x00, 0x50, 0x6a, 0xdf, 0xfe, 0x3f, 0x00, 0x00, + 0x00, 0x48, 0xe9, 0x4a, 0x05, 0x08, 0x00, 0xa5, 0xd5, 0xf5, 0xff, 0x3f, + 0x10, 0x01, 0x10, 0x01, 0xb0, 0xab, 0x92, 0x02, 0x40, 0xf8, 0xbf, 0xde, + 0xfe, 0x5f, 0x02, 0x04, 0x04, 0x48, 0xfa, 0xd4, 0x6f, 0x20, 0x84, 0xef, + 0xff, 0xfb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x00, 0xe0, 0xed, 0xbf, 0x0b, + 0xa1, 0x7e, 0xff, 0xbf, 0xfd, 0x5f, 0x04, 0x01, 0x20, 0x49, 0xd2, 0xfb, + 0xfe, 0x55, 0xd4, 0xff, 0xff, 0xf6, 0xff, 0x07, 0x00, 0x04, 0x00, 0x00, + 0xc0, 0xaa, 0xfb, 0x2b, 0xa2, 0xfe, 0xff, 0xdf, 0xee, 0x1f, 0x91, 0x00, + 0x82, 0xa4, 0xa4, 0xf5, 0xff, 0x57, 0xd5, 0xff, 0xbf, 0xfd, 0xff, 0x4d, + 0x00, 0x00, 0x20, 0x00, 0x88, 0x5b, 0xff, 0x2f, 0x69, 0xff, 0xff, 0xdb, + 0xfe, 0x1f, 0x24, 0x02, 0x00, 0x49, 0xa2, 0xd6, 0xff, 0x5f, 0xea, 0xff, + 0x7f, 0x7f, 0x7f, 0x0d, 0x00, 0x00, 0x10, 0x00, 0x40, 0xab, 0xf7, 0xbb, + 0xf0, 0xdf, 0xff, 0xd5, 0xff, 0xbf, 0x82, 0x04, 0x42, 0x24, 0x91, 0xd5, + 0xaa, 0xae, 0xd4, 0xaa, 0x52, 0x7b, 0xff, 0x15, 0x08, 0x00, 0x00, 0x01, + 0x04, 0x55, 0xd5, 0x55, 0x70, 0x5b, 0x75, 0xdd, 0xdf, 0x1f, 0x40, 0x00, + 0x08, 0x48, 0xa0, 0x4a, 0xa9, 0x56, 0xea, 0x56, 0xad, 0x6a, 0x7d, 0x9b, + 0x04, 0x01, 0x00, 0x02, 0x42, 0x2a, 0xd5, 0xaa, 0xa8, 0xaa, 0xaa, 0xfa, + 0xdf, 0x2f, 0x10, 0x04, 0x22, 0x48, 0x08, 0x45, 0x2a, 0x15, 0x68, 0x55, + 0x55, 0xd7, 0x76, 0x1b, 0x00, 0x00, 0x00, 0x01, 0x40, 0x2a, 0x80, 0xa0, + 0xb2, 0x09, 0x48, 0xb9, 0xdf, 0x17, 0x22, 0x01, 0x00, 0x24, 0x45, 0x8a, + 0x24, 0x4a, 0x54, 0x51, 0x91, 0xf6, 0x6e, 0x4b, 0x00, 0x04, 0x90, 0x00, + 0x80, 0x52, 0x00, 0x20, 0x69, 0x05, 0xa4, 0xaa, 0xff, 0x1e, 0x48, 0x00, + 0x02, 0x92, 0x08, 0x05, 0x81, 0x94, 0xd4, 0x92, 0x40, 0xfd, 0xb6, 0x8b, + 0x00, 0x01, 0x40, 0x00, 0x82, 0x54, 0x00, 0x48, 0x68, 0x05, 0x90, 0xa4, + 0xef, 0x06, 0x24, 0x00, 0x08, 0x12, 0x10, 0x05, 0x00, 0x10, 0xb5, 0x01, + 0x42, 0xfb, 0xbf, 0x43, 0x00, 0x09, 0x00, 0x40, 0x81, 0xa8, 0x08, 0x4a, + 0xaa, 0x96, 0x90, 0xac, 0x6d, 0x15, 0x22, 0x00, 0x20, 0x09, 0x04, 0x15, + 0x80, 0x28, 0xdc, 0x01, 0x24, 0xfb, 0xbf, 0x01, 0x80, 0x04, 0x09, 0x00, + 0x40, 0x48, 0x02, 0x45, 0xb2, 0x2e, 0x41, 0x6d, 0xef, 0x05, 0x11, 0x00, + 0x40, 0x52, 0x02, 0x15, 0x29, 0x2a, 0xac, 0x42, 0x54, 0xfb, 0x3b, 0x51, + 0x84, 0x00, 0x08, 0x00, 0x20, 0x54, 0x80, 0x05, 0xb5, 0x3d, 0xa2, 0xb6, + 0xdf, 0x00, 0x20, 0x04, 0x20, 0x49, 0x89, 0xa8, 0x6a, 0x29, 0xac, 0xd6, + 0x54, 0xff, 0x3f, 0x84, 0x00, 0x01, 0x04, 0x10, 0x00, 0x94, 0xa8, 0x56, + 0xda, 0x5f, 0xab, 0xd5, 0x1e, 0x10, 0x48, 0x00, 0x90, 0x82, 0x48, 0xa8, + 0xb2, 0xac, 0xfd, 0x55, 0xd5, 0xfe, 0x9f, 0x80, 0x00, 0x0a, 0x02, 0x08, + 0x02, 0x55, 0x5a, 0x75, 0xff, 0xaf, 0xb6, 0xf7, 0x2d, 0x12, 0x92, 0x00, + 0x10, 0x20, 0x10, 0xa8, 0x54, 0xd5, 0xbf, 0x5d, 0xad, 0xdd, 0x0f, 0x00, + 0x00, 0x04, 0x40, 0x09, 0x84, 0xa8, 0xaa, 0x5a, 0xed, 0xeb, 0x6a, 0xff, + 0x9f, 0xa4, 0x24, 0x01, 0x02, 0xa0, 0x20, 0x50, 0x55, 0xd5, 0xbe, 0xae, + 0xad, 0xfd, 0x16, 0x00, 0x10, 0x04, 0x20, 0x0a, 0x08, 0xb4, 0xaa, 0x95, + 0xaa, 0x7b, 0xb7, 0xdb, 0x5f, 0x92, 0x04, 0x01, 0x84, 0x20, 0x21, 0x51, + 0xd5, 0x2a, 0xa9, 0xee, 0xd5, 0xfe, 0x0d, 0x00, 0x20, 0x04, 0x10, 0x00, + 0x08, 0x50, 0xe9, 0xd7, 0xd4, 0xfb, 0xb5, 0xff, 0x9f, 0x24, 0x09, 0x01, + 0x42, 0x4a, 0xa2, 0x64, 0xd5, 0x55, 0x7b, 0x7f, 0xda, 0x7d, 0x4f, 0x00, + 0x20, 0x04, 0x00, 0x80, 0x00, 0xa0, 0x2a, 0x13, 0x84, 0x6a, 0x55, 0xff, + 0x1d, 0x48, 0x8a, 0x00, 0x94, 0x24, 0x8a, 0xc8, 0xaa, 0x42, 0x20, 0x5d, + 0xf5, 0xff, 0x5f, 0x01, 0x00, 0x02, 0x01, 0x00, 0x20, 0xa2, 0x4a, 0x1a, + 0x82, 0x56, 0xda, 0xbd, 0x3f, 0x92, 0x92, 0x00, 0x90, 0x92, 0x00, 0x40, + 0x95, 0x6a, 0xf4, 0x55, 0x6d, 0xff, 0xd6, 0x00, 0x00, 0x0a, 0x04, 0x20, + 0x14, 0x49, 0x4b, 0xaa, 0xaa, 0x56, 0xf5, 0xff, 0xbf, 0xab, 0xa4, 0x00, + 0x20, 0x89, 0x40, 0x80, 0xaa, 0xaa, 0xaa, 0xaa, 0xde, 0xbf, 0xeb, 0x03, + 0x00, 0x02, 0x04, 0x02, 0x0a, 0x10, 0x2b, 0x2a, 0x55, 0x5b, 0xf5, 0xff, + 0xd7, 0x2f, 0x92, 0x00, 0x10, 0x28, 0x21, 0x01, 0x56, 0x95, 0xa0, 0x56, + 0xdf, 0xef, 0xea, 0x87, 0x40, 0x0a, 0x42, 0x41, 0x00, 0x90, 0xaa, 0x52, + 0xb6, 0xad, 0xfa, 0xff, 0xd5, 0x2f, 0x14, 0x00, 0x00, 0x04, 0x95, 0x04, + 0xaa, 0xac, 0x55, 0x6b, 0xff, 0xb7, 0xea, 0x9f, 0x40, 0x02, 0x28, 0x51, + 0x00, 0x40, 0x58, 0xd5, 0xda, 0xd6, 0x6e, 0x7f, 0xf9, 0x3f, 0x12, 0x04, + 0x02, 0x04, 0x49, 0x25, 0x55, 0xaa, 0x77, 0xab, 0xff, 0x2b, 0xfd, 0x3f, + 0x48, 0x01, 0x20, 0x41, 0x00, 0x00, 0x58, 0xa9, 0xda, 0xea, 0xfd, 0xaf, + 0xfa, 0xff, 0x02, 0x04, 0x08, 0x14, 0x29, 0x49, 0x52, 0x55, 0x55, 0x55, + 0xff, 0x8d, 0xfe, 0x3f, 0xa8, 0x00, 0x02, 0x41, 0x00, 0x02, 0xa0, 0xa2, + 0xaa, 0xea, 0xff, 0x53, 0xfd, 0xff, 0x02, 0x04, 0x50, 0x04, 0x25, 0xa8, + 0x54, 0x49, 0x52, 0xb5, 0xbf, 0x8a, 0xfe, 0xff, 0xa9, 0x08, 0x04, 0x50, + 0x80, 0x02, 0xa1, 0x2a, 0x95, 0xea, 0xff, 0xa1, 0xff, 0xff, 0x03, 0x02, + 0x90, 0x02, 0x09, 0x08, 0x44, 0x49, 0x52, 0xbd, 0x7f, 0xca, 0xff, 0xff, + 0x2b, 0x09, 0x04, 0x48, 0x40, 0x82, 0x90, 0x56, 0xa9, 0xf6, 0xbf, 0xd0, + 0xff, 0xff, 0x47, 0x00, 0x50, 0x02, 0x15, 0x11, 0x40, 0x95, 0xaa, 0xfd, + 0x2f, 0xe9, 0xff, 0xff, 0x8f, 0x0a, 0x84, 0x50, 0x40, 0x84, 0x14, 0xaa, + 0x6a, 0xff, 0x5f, 0xf2, 0xff, 0xff, 0x7f, 0x00, 0x10, 0x02, 0x09, 0x10, + 0x40, 0x7d, 0xf7, 0xff, 0x0b, 0xfc, 0xff, 0xff, 0xaf, 0x02, 0x84, 0x50, + 0x42, 0x85, 0x12, 0xd0, 0xdd, 0xff, 0xa7, 0xf2, 0xff, 0xff, 0xff, 0x04, + 0x00, 0x0a, 0x08, 0x10, 0x48, 0xf8, 0xff, 0xff, 0x0a, 0xfe, 0xff, 0xff, + 0x7f, 0x03, 0xa4, 0x80, 0xa2, 0x8a, 0x02, 0x68, 0xff, 0xff, 0x52, 0xfd, + 0xff, 0xff, 0xff, 0x07, 0x00, 0x2a, 0x08, 0x20, 0x28, 0xdc, 0xff, 0x5f, + 0x05, 0xff, 0xff, 0xff, 0xff, 0x0d, 0x92, 0x40, 0x22, 0x09, 0x02, 0xea, + 0xfb, 0xaf, 0x48, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x12, 0x81, 0xa0, + 0x48, 0x9c, 0x6e, 0x93, 0xa2, 0xff, 0xff, 0xff, 0xff, 0x07, 0xa8, 0x40, + 0x28, 0x0a, 0x02, 0x74, 0xb5, 0x45, 0x81, 0xff, 0xff, 0xff, 0xff, 0x0f, + 0x02, 0x0a, 0x81, 0x20, 0x08, 0xae, 0xaa, 0x90, 0xe8, 0xff, 0xff, 0xff, + 0xff, 0x0f, 0x90, 0x40, 0x28, 0x88, 0x12, 0x58, 0x15, 0x50, 0xd0, 0xff, + 0xff, 0xff, 0xff, 0x0f, 0x44, 0x0a, 0x41, 0x21, 0x08, 0xae, 0x04, 0x14, + 0xf0, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40, 0x14, 0x88, 0x04, 0xba, + 0x02, 0x28, 0xe8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x42, 0x15, 0x41, 0x21, + 0x05, 0xad, 0x00, 0x05, 0xf8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40, + 0x24, 0x8a, 0x0e, 0x36, 0x00, 0x0a, 0xf4, 0xff, 0xff, 0xff, 0xff, 0x0f, + 0x42, 0x25, 0x90, 0xd0, 0x8b, 0xc2, 0x41, 0x05, 0xfc, 0xff, 0xff, 0xff, + 0xff, 0x0f, 0x10, 0x08, 0x05, 0xe8, 0x8e, 0x58, 0x80, 0x02, 0xfa, 0xff, + 0xff, 0xff, 0xff, 0x0f, 0x4a, 0x20, 0xa8, 0xba, 0x0b, 0x2b, 0x51, 0x01, + 0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x8a, 0x02, 0xe8, 0xaf, 0x84, + 0x90, 0x04, 0xfd, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x52, 0x21, 0x54, 0xbf, + 0x1f, 0x15, 0xa5, 0x02, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x08, + 0x01, 0xfa, 0xb6, 0xa4, 0x52, 0x40, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, + 0x4a, 0xa2, 0x54, 0xef, 0x5f, 0x4b, 0xa4, 0x80, 0xff, 0xff, 0xff, 0xff, + 0xff, 0x0f, 0x80, 0x10, 0x82, 0xfe, 0xbf, 0x92, 0x52, 0x42, 0xff, 0xff, + 0xff, 0xff, 0xff, 0x0f, 0x12, 0x42, 0xa8, 0xbf, 0x1f, 0x24, 0x80, 0xa0, + 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28, 0x8a, 0xf7, 0x37, 0x80, + 0x52, 0x80, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x82, 0xe0, 0xff, + 0x1f, 0x00, 0x20, 0xe1, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28, + 0xca, 0xff, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, + 0x10, 0x42, 0xf0, 0xfd, 0x1b, 0x00, 0x50, 0xf0, 0xff, 0xff, 0xff, 0xff, + 0xff, 0x0f, 0xa4, 0x10, 0xc5, 0xff, 0x1f, 0x00, 0x00, 0xe0, 0xff, 0xff, + 0xff, 0xff, 0xff, 0x0f, 0x00, 0x22, 0xf8, 0xff, 0x0e, 0x00, 0x00, 0xf0, + 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xaa, 0x88, 0xe2, 0xff, 0x0f, 0x10, + 0x00, 0xf0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x25, 0xfa, 0xff, + 0x0f, 0x01, 0x11, 0xfd, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xff, 0xfb, + 0xfb, 0xff, 0x7f, 0x5d, 0xd5, 0xfa, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f}; diff --git a/tests/filebox.test b/tests/filebox.test index 353cc97..bbd468b 100644 --- a/tests/filebox.test +++ b/tests/filebox.test @@ -7,14 +7,22 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile +test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} { + # MacOS type that is too long + + set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg] + regsub -all "\0" $res {\\0} +} {1 {bad Macintosh file type "\0\0\0\0\0"}} +test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} { + # MacOS type that is too short, but looks ok in utf (4 bytes). + + set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg] + regsub -all "\0" $msg {\\0} msg + list $x $msg +} {1 {bad Macintosh file type "\0\0"}} set tk_strictMotif_old $tk_strictMotif @@ -102,8 +110,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, -title, or -typevariable} +set unknownOptionsMsg(tk_getSaveFile) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable} set tmpFile "filebox.tmp" makeFile { @@ -130,12 +138,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 {} @@ -148,46 +155,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 + } -returnCodes 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 @@ -200,111 +203,125 @@ 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 fileDir [tcltest::temporaryDirectory] 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 { + cd $fileDir 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 } + foreach {x res} [list 1 "-unset-" 2 "Text files"] { + set t [expr {$x + [llength [array names filters]]}] + test filebox-3.$t-$mode "tk_getOpenFile command" nonUnixUserInteraction { + catch {unset tv} + catch {unset typeName} + ToPressButton $parent ok + if {[info exists tv]} { + } else { + } + set choice [tk_getOpenFile -title "Press Ok" \ + -filetypes $filters($x) -parent $parent \ + -initialfile $fileName -initialdir $fileDir \ + -typevariable tv] + if {[info exists tv]} { + regexp {^(.*) \(.*\)$} $tv dummy typeName + } else { + set typeName "-unset-" + } + set typeName + } $res + } - 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 . @@ -320,7 +337,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 } "" @@ -329,65 +346,122 @@ 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] } + if {!$mode} { + + test filebox-7.1-$mode "tk_getOpenFile - directory not readable" \ + -constraints nonUnixUserInteraction \ + -setup { + rename ::tk_messageBox ::saved_messageBox + set ::gotmessage {} + proc tk_messageBox args { + set ::gotmessage $args + } + toplevel .t1 + file mkdir [file join $fileDir NOTREADABLE] + file attributes [file join $fileDir NOTREADABLE] \ + -permissions 300 + } \ + -cleanup { + rename ::tk_messageBox {} + rename ::saved_messageBox ::tk_messageBox + unset ::gotmessage + destroy .t1 + file delete -force [file join $fileDir NOTREADABLE] + } \ + -body { + ToEnterFileByKey .t1 NOTREADABLE $fileDir + ToPressButton .t1 ok + ToPressButton .t1 cancel + tk_getOpenFile -parent .t1 \ + -title "Please select the NOTREADABLE directory" \ + -initialdir $fileDir + set gotmessage + } \ + -match glob \ + -result "*NOTREADABLE*" + + test filebox-7.2-$mode "tk_getOpenFile - bad file name" \ + -constraints nonUnixUserInteraction \ + -setup { + rename ::tk_messageBox ::saved_messageBox + set ::gotmessage {} + proc tk_messageBox args { + set ::gotmessage $args + } + toplevel .t1 + } \ + -cleanup { + rename ::tk_messageBox {} + rename ::saved_messageBox ::tk_messageBox + unset ::gotmessage + destroy .t1 + } \ + -body { + ToEnterFileByKey .t1 RUBBISH $fileDir + ToPressButton .t1 ok + ToPressButton .t1 cancel + tk_getOpenFile -parent .t1 \ + -title "Please enter RUBBISH as a file name" \ + -initialdir $fileDir + set gotmessage + } \ + -match glob \ + -result "*RUBBISH*" + } + # The rest of the tests need to be executed on Unix only. # The test whether the dialog box widgets were implemented correctly. # These tests are not @@ -397,5 +471,6 @@ foreach mode $modes { set tk_strictMotif $tk_strictMotif_old # cleanup -::tcltest::cleanupTests +removeFile filebox.tmp +cleanupTests return diff --git a/tests/flagdown.xbm b/tests/flagdown.xbm new file mode 100644 index 0000000..55abc51 --- /dev/null +++ b/tests/flagdown.xbm @@ -0,0 +1,27 @@ +#define flagdown_width 48 +#define flagdown_height 48 +static char flagdown_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, + 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xe1, 0x00, 0x00, + 0x00, 0x00, 0x70, 0x80, 0x01, 0x00, 0x00, 0x00, 0x18, 0x00, 0x03, 0x00, + 0x00, 0x00, 0x0c, 0x00, 0x03, 0x00, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, + 0x00, 0x00, 0x03, 0x00, 0x06, 0x06, 0x00, 0x80, 0x01, 0x00, 0x06, 0x07, + 0x00, 0xc0, 0x1f, 0x00, 0x87, 0x07, 0x00, 0xe0, 0x7f, 0x80, 0xc7, 0x07, + 0x00, 0x70, 0xe0, 0xc0, 0xe5, 0x07, 0x00, 0x38, 0x80, 0xe1, 0x74, 0x07, + 0x00, 0x18, 0x80, 0x71, 0x3c, 0x07, 0x00, 0x0c, 0x00, 0x3b, 0x1e, 0x03, + 0x00, 0x0c, 0x00, 0x1f, 0x0f, 0x00, 0x00, 0x86, 0x1f, 0x8e, 0x07, 0x00, + 0x00, 0x06, 0x06, 0xc6, 0x05, 0x00, 0x00, 0x06, 0x00, 0xc6, 0x05, 0x00, + 0x00, 0x06, 0x00, 0xc6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, + 0x7f, 0x06, 0x00, 0x06, 0xe4, 0xff, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, + 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x06, 0x00, + 0x00, 0x06, 0x00, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00, + 0x00, 0x06, 0x00, 0xc6, 0x00, 0x00, 0x00, 0x06, 0x00, 0x66, 0x00, 0x00, + 0x00, 0x06, 0x00, 0x36, 0x00, 0x00, 0x00, 0x06, 0x00, 0x3e, 0x00, 0x00, + 0x00, 0xfe, 0xff, 0x2f, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x27, 0x00, 0x00, + 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, + 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, + 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, + 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, + 0xf7, 0xbf, 0x8e, 0xfc, 0xdf, 0xf8, 0x9d, 0xeb, 0x9b, 0x76, 0xd2, 0x7a, + 0x46, 0x30, 0xe2, 0x0f, 0xe1, 0x47, 0x55, 0x84, 0x48, 0x11, 0x84, 0x19}; diff --git a/tests/flagup.xbm b/tests/flagup.xbm new file mode 100644 index 0000000..6eb0d84 --- /dev/null +++ b/tests/flagup.xbm @@ -0,0 +1,27 @@ +#define flagup_width 48 +#define flagup_height 48 +static char flagup_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, + 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xef, 0x6a, 0x00, + 0x00, 0x00, 0xc0, 0x7b, 0x75, 0x00, 0x00, 0x00, 0xe0, 0xe0, 0x6a, 0x00, + 0x00, 0x00, 0x30, 0x60, 0x75, 0x00, 0x00, 0x00, 0x18, 0xe0, 0x7f, 0x00, + 0x00, 0x00, 0x0c, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x06, 0xe0, 0x04, 0x00, + 0x00, 0x00, 0x03, 0xe0, 0x04, 0x00, 0x00, 0x80, 0x01, 0xe0, 0x06, 0x00, + 0x00, 0xc0, 0x1f, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x7f, 0xe0, 0x07, 0x00, + 0x00, 0x70, 0xe0, 0xe0, 0x05, 0x00, 0x00, 0x38, 0x80, 0xe1, 0x04, 0x00, + 0x00, 0x18, 0x80, 0xf1, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xfb, 0x04, 0x00, + 0x00, 0x0c, 0x00, 0xff, 0x04, 0x00, 0x00, 0x86, 0x1f, 0xee, 0x04, 0x00, + 0x00, 0x06, 0x06, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, + 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x66, 0x04, 0x00, + 0x7f, 0x56, 0x52, 0x06, 0xe4, 0xff, 0x00, 0x76, 0x55, 0x06, 0x04, 0x00, + 0x00, 0x56, 0x57, 0x06, 0x04, 0x00, 0x00, 0x56, 0x55, 0x06, 0x06, 0x00, + 0x00, 0x56, 0xd5, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00, + 0x54, 0x06, 0x00, 0xc6, 0x54, 0x55, 0xaa, 0x06, 0x00, 0x66, 0xaa, 0x2a, + 0x54, 0x06, 0x00, 0x36, 0x55, 0x55, 0xaa, 0x06, 0x00, 0xbe, 0xaa, 0x2a, + 0x54, 0xfe, 0xff, 0x6f, 0x55, 0x55, 0xaa, 0xfc, 0xff, 0xa7, 0xaa, 0x2a, + 0x54, 0x01, 0x88, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, + 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, + 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, + 0x54, 0x55, 0x8d, 0x50, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa8, 0xaa, 0x2a, + 0x54, 0x55, 0x95, 0x54, 0x55, 0x55, 0xaa, 0xaa, 0xaa, 0xaa, 0xaa, 0x2a, + 0x54, 0x55, 0x55, 0x55, 0x55, 0x15, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; diff --git a/tests/focus.test b/tests/focus.test index 474f49a..5cc3abe 100644 --- a/tests/focus.test +++ b/tests/focus.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands button .b -text .b -relief raised -bd 2 @@ -71,35 +68,35 @@ bind all <KeyPress> { append focusInfo "press %W %K" } -test focus-1.1 {Tk_FocusCmd procedure} {unixOnly} { +test focus-1.1 {Tk_FocusCmd procedure} unix { focusClear focus } {} -test focus-1.2 {Tk_FocusCmd procedure} {unixOnly altDisplay} { +test focus-1.2 {Tk_FocusCmd procedure} {unix altDisplay} { focus .alt.b focus } {} -test focus-1.3 {Tk_FocusCmd procedure} {unixOnly} { +test focus-1.3 {Tk_FocusCmd procedure} unix { focusClear focus .t.b3 focus } {} -test focus-1.4 {Tk_FocusCmd procedure} {unixOnly} { +test focus-1.4 {Tk_FocusCmd procedure} unix { list [catch {focus ""} msg] $msg } {0 {}} -test focus-1.5 {Tk_FocusCmd procedure} {unixOnly} { +test focus-1.5 {Tk_FocusCmd procedure} unix { focusClear focus -force .t focus .t.b3 focus } {.t.b3} -test focus-1.6 {Tk_FocusCmd procedure} {unixOnly} { +test focus-1.6 {Tk_FocusCmd procedure} unix { list [catch {focus .gorp} msg] $msg } {1 {bad window path name ".gorp"}} -test focus-1.7 {Tk_FocusCmd procedure} {unixOnly} { +test focus-1.7 {Tk_FocusCmd procedure} unix { list [catch {focus .gorp a} msg] $msg } {1 {bad option ".gorp": must be -displayof, -force, or -lastfor}} -test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} {unixOnly} { +test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} unix { toplevel .t2 wm geom .t2 +10+10 frame .t2.f -width 200 -height 100 -bd 2 -relief raised @@ -118,73 +115,73 @@ test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} {unixOnly} { destroy .t2 set x } {.t2.f2 .t2 .t2} -test focus-1.9 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { +test focus-1.9 {Tk_FocusCmd procedure, -displayof option} unix { list [catch {focus -displayof} msg] $msg } {1 {wrong # args: should be "focus -displayof window"}} -test focus-1.10 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { +test focus-1.10 {Tk_FocusCmd procedure, -displayof option} unix { list [catch {focus -displayof a b} msg] $msg } {1 {wrong # args: should be "focus -displayof window"}} -test focus-1.11 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { +test focus-1.11 {Tk_FocusCmd procedure, -displayof option} unix { list [catch {focus -displayof .lousy} msg] $msg } {1 {bad window path name ".lousy"}} -test focus-1.12 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { +test focus-1.12 {Tk_FocusCmd procedure, -displayof option} unix { focusClear focus .t focus -displayof .t.b3 } {} -test focus-1.13 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { +test focus-1.13 {Tk_FocusCmd procedure, -displayof option} unix { focusClear focus -force .t focus -displayof .t.b3 } {.t} -test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {unixOnly altDisplay} { +test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {unix altDisplay} { focus -force .alt.c focus -displayof .alt } {.alt.c} -test focus-1.15 {Tk_FocusCmd procedure, -force option} {unixOnly} { +test focus-1.15 {Tk_FocusCmd procedure, -force option} unix { list [catch {focus -force} msg] $msg } {1 {wrong # args: should be "focus -force window"}} -test focus-1.16 {Tk_FocusCmd procedure, -force option} {unixOnly} { +test focus-1.16 {Tk_FocusCmd procedure, -force option} unix { list [catch {focus -force a b} msg] $msg } {1 {wrong # args: should be "focus -force window"}} -test focus-1.17 {Tk_FocusCmd procedure, -force option} {unixOnly} { +test focus-1.17 {Tk_FocusCmd procedure, -force option} unix { list [catch {focus -force foo} msg] $msg } {1 {bad window path name "foo"}} -test focus-1.18 {Tk_FocusCmd procedure, -force option} {unixOnly} { +test focus-1.18 {Tk_FocusCmd procedure, -force option} unix { list [catch {focus -force ""} msg] $msg } {0 {}} -test focus-1.19 {Tk_FocusCmd procedure, -force option} {unixOnly} { +test focus-1.19 {Tk_FocusCmd procedure, -force option} unix { focusClear focus .t.b1 set x [list [focus]] focus -force .t.b1 lappend x [focus] } {{} .t.b1} -test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { +test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} unix { list [catch {focus -lastfor} msg] $msg } {1 {wrong # args: should be "focus -lastfor window"}} -test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { +test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} unix { list [catch {focus -lastfor 1 2} msg] $msg } {1 {wrong # args: should be "focus -lastfor window"}} -test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { +test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} unix { list [catch {focus -lastfor who_knows?} msg] $msg } {1 {bad window path name "who_knows?"}} -test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { +test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} unix { focus .b focus .t.b1 list [focus -lastfor .] [focus -lastfor .t.b3] } {.b .t.b1} -test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { +test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} unix { destroy .t focusSetup update focus -lastfor .t.b2 } {.t} -test focus-1.25 {Tk_FocusCmd procedure} {unixOnly} { +test focus-1.25 {Tk_FocusCmd procedure} unix { list [catch {focus -unknown} msg] $msg } {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}} -test focus-2.1 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} { +test focus-2.1 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { focus -force .b destroy .t focusSetup @@ -194,7 +191,7 @@ test focus-2.1 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} -sendevent 0x54217567 list $focusInfo } {{}} -test focus-2.2 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} { +test focus-2.2 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { focus -force .b destroy .t focusSetup @@ -204,7 +201,7 @@ test focus-2.2 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} list $focusInfo [focus] } {{in .t NotifyAncestor } .b} -test focus-2.3 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} { +test focus-2.3 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { focus -force .b destroy .t focusSetup @@ -218,7 +215,7 @@ out . NotifyNonlinearVirtual in .t NotifyNonlinear } .t} test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \ - {unixOnly nonPortable testwrapper} { + {unix nonPortable testwrapper} { set result {} focus .t.b1 # Important to end with NotifyAncestor, which is an @@ -249,7 +246,7 @@ in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear }} test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} \ - {unixOnly nonPortable testwrapper} { + {unix nonPortable testwrapper} { focusSetup focus .t.b1 update @@ -260,7 +257,7 @@ in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } .t.b1} test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \ - {unixOnly testwrapper} { + {unix testwrapper} { focus .t.b1 focus . update @@ -271,7 +268,7 @@ test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \ list $x $focusInfo } {.t.b1 {press .t.b1 x}} test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} \ - {unixOnly testwrapper} { + {unix testwrapper} { set result {} foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot @@ -284,19 +281,19 @@ test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} \ set result } {{} .t.b1 {} {} .t.b1 .t.b1 {}} test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} \ - {unixOnly testwrapper} { + {unix testwrapper} { focus -force .t.b1 event gen .t.b1 <FocusOut> -detail NotifyAncestor focus } {.t.b1} test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} \ - {unixOnly testwrapper} { + {unix testwrapper} { focus .t.b1 event gen [testwrapper .] <FocusOut> -detail NotifyAncestor focus } {} test focus-2.10 {TkFocusFilterEvent procedure, Enter events} \ - {unixOnly testwrapper} { + {unix testwrapper} { set result {} focus .t.b1 focusClear @@ -311,7 +308,7 @@ test focus-2.10 {TkFocusFilterEvent procedure, Enter events} \ set result } {.t.b1 {} .t.b1 .t.b1 .t.b1} test focus-2.11 {TkFocusFilterEvent procedure, Enter events} \ - {unixOnly testwrapper} { + {unix testwrapper} { focusClear set focusInfo {} event gen [testwrapper .t] <Enter> -detail NotifyAncestor @@ -319,7 +316,7 @@ test focus-2.11 {TkFocusFilterEvent procedure, Enter events} \ set focusInfo } {} test focus-2.12 {TkFocusFilterEvent procedure, Enter events} \ - {unixOnly testwrapper} { + {unix testwrapper} { focus -force .b update set focusInfo {} @@ -328,7 +325,7 @@ test focus-2.12 {TkFocusFilterEvent procedure, Enter events} \ set focusInfo } {} test focus-2.13 {TkFocusFilterEvent procedure, Enter events} \ - {unixOnly testwrapper} { + {unix testwrapper} { focus .t.b1 focusClear event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 @@ -338,7 +335,7 @@ test focus-2.13 {TkFocusFilterEvent procedure, Enter events} \ } {in .t NotifyVirtual in .t.b1 NotifyAncestor } -test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} {unixOnly testwrapper} { +test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} {unix testwrapper} { focusClear catch {destroy .t2} toplevel .t2 @@ -350,7 +347,7 @@ test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when destroy .t2 } {} test focus-2.15 {TkFocusFilterEvent procedure, Leave events} \ - {unixOnly testwrapper} { + {unix testwrapper} { set result {} focus .t.b1 foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear @@ -365,7 +362,7 @@ test focus-2.15 {TkFocusFilterEvent procedure, Leave events} \ set result } {{} .t.b1 {} {} {}} test focus-2.16 {TkFocusFilterEvent procedure, Leave events} \ - {unixOnly testwrapper} { + {unix testwrapper} { set result {} focus .t.b1 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 @@ -378,7 +375,7 @@ test focus-2.16 {TkFocusFilterEvent procedure, Leave events} \ out .t NotifyVirtual } test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \ - {unixOnly testwrapper} { + {unix testwrapper} { set result {} focus .t.b1 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 @@ -393,7 +390,7 @@ out .t NotifyVirtual } {}} test focus-3.1 {SetFocus procedure, create record on focus} \ - {unixOnly testwrapper} { + {unix testwrapper} { toplevel .t2 -width 250 -height 100 wm geometry .t2 +0+0 update @@ -405,8 +402,7 @@ catch {destroy .t2} # This test produces no result, but it will generate a protocol # error if Tk forgets to make the window exist before focussing # on it. -test focus-3.2 {SetFocus procedure, making window exist} \ - {unixOnly testwrapper} { +test focus-3.2 {SetFocus procedure, making window exist} {unix testwrapper} { update button .b2 -text "Another button" focus .b2 @@ -417,13 +413,13 @@ update # The following test doesn't produce a check-able result, but if # there are bugs it may generate an X protocol error. test focus-3.3 {SetFocus procedure, delaying claim of X focus} \ - {unixOnly testwrapper} { + {unix testwrapper} { focusSetup focus -force .t.b2 update } {} test focus-3.4 {SetFocus procedure, delaying claim of X focus} \ - {unixOnly testwrapper} { + {unix testwrapper} { focusSetup wm withdraw .t focus -force .t.b2 @@ -436,8 +432,7 @@ test focus-3.4 {SetFocus procedure, delaying claim of X focus} \ wm deiconify .t } {} catch {destroy .t2} -test focus-3.5 {SetFocus procedure, generating events} \ - {unixOnly testwrapper} { +test focus-3.5 {SetFocus procedure, generating events} {unix testwrapper} { focusSetup focusClear set focusInfo {} @@ -447,8 +442,7 @@ test focus-3.5 {SetFocus procedure, generating events} \ } {in .t NotifyVirtual in .t.b2 NotifyAncestor } -test focus-3.6 {SetFocus procedure, generating events} \ - {unixOnly testwrapper} { +test focus-3.6 {SetFocus procedure, generating events} {unix testwrapper} { focusSetup focus -force .b update @@ -462,7 +456,7 @@ in .t NotifyNonlinearVirtual in .t.b2 NotifyNonlinear } test focus-3.7 {SetFocus procedure, generating events} \ - {unixOnly nonPortable testwrapper} { + {unix nonPortable testwrapper} { # Non-portable because some platforms generate extra events. focusSetup @@ -473,7 +467,7 @@ test focus-3.7 {SetFocus procedure, generating events} \ set focusInfo } {} -test focus-4.1 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { +test focus-4.1 {TkFocusDeadWindow procedure} {unix testwrapper} { focusSetup update focus -force .b @@ -481,7 +475,7 @@ test focus-4.1 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { destroy .t focus } {.b} -test focus-4.2 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { +test focus-4.2 {TkFocusDeadWindow procedure} {unix testwrapper} { focusSetup update focus -force .t.b2 @@ -495,7 +489,7 @@ test focus-4.2 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { # Non-portable due to wm-specific redirection of input focus when # windows are deleted: -test focus-4.3 {TkFocusDeadWindow procedure} {unixOnly nonPortable testwrapper} { +test focus-4.3 {TkFocusDeadWindow procedure} {unix nonPortable testwrapper} { focusSetup update focus .t @@ -504,7 +498,7 @@ test focus-4.3 {TkFocusDeadWindow procedure} {unixOnly nonPortable testwrapper} update focus } {} -test focus-4.4 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { +test focus-4.4 {TkFocusDeadWindow procedure} {unix testwrapper} { focusSetup focus -force .t.b2 update @@ -517,7 +511,7 @@ test focus-4.4 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { setupbg test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \ - {unixOnly testwrapper secureserver} { + {unix testwrapper secureserver} { focusSetup focus -force .t update @@ -537,7 +531,7 @@ cleanupbg fixfocus test focus-6.1 {miscellaneous - embedded application in same process} \ - {unixOnly testwrapper} { + {unix testwrapper} { eval interp delete [interp slaves] catch {destroy .t} toplevel .t @@ -587,7 +581,7 @@ test focus-6.1 {miscellaneous - embedded application in same process} \ set result } {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} test focus-6.2 {miscellaneous - embedded application in different process} \ - {unixOnly testwrapper} { + {unix testwrapper} { eval interp delete [interp slaves] catch {destroy .t} setupbg @@ -641,18 +635,5 @@ bind all <FocusIn> {} bind all <FocusOut> {} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/focusTcl.test b/tests/focusTcl.test index efeab92..1f5eed5 100644 --- a/tests/focusTcl.test +++ b/tests/focusTcl.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands proc setup1 w { @@ -277,18 +274,5 @@ bind Frame <Key> {} option clear # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/font.test b/tests/font.test index 643cc79..34e4b83 100644 --- a/tests/font.test +++ b/tests/font.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands catch {destroy .b} @@ -49,11 +46,14 @@ proc csetup {{str ""}} { setup -case $tcl_platform(platform) { - unix {set fixed "fixed"} - windows {set fixed "courier 12"} - macintosh {set fixed "monaco 9"} +case [tk windowingsystem] { + x11 {set fixed "fixed"} + win32 {set fixed "courier 12"} + classic - + aqua {set fixed "monaco 9"} } + + set times [font actual {times 0} -family] test font-1.1 {TkFontPkgInit} { @@ -113,11 +113,11 @@ test font-4.1 {font command: actual: arguments} { test font-4.2 {font command: actual: arguments} { # (objc < 3) list [catch {font actual} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} +} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}} test font-4.3 {font command: actual: arguments} { # (objc - skip > 4) when skip == 0 list [catch {font actual xyz abc def} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} +} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}} test font-4.4 {font command: actual: displayof specified, so skip to next} { catch {font actual xyz -displayof . -size} } {0} @@ -127,7 +127,7 @@ test font-4.5 {font command: actual: displayof specified, so skip to next} { test font-4.6 {font command: actual: arguments} { # (objc - skip > 4) when skip == 2 list [catch {font actual xyz -displayof . abc def} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} +} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}} test font-4.7 {font command: actual: arguments} {noExceed} { # (tkfont == NULL) list [catch {font actual "\{xyz"} msg] $msg @@ -136,11 +136,11 @@ test font-4.8 {font command: actual: all attributes} { # not (objc > 3) so objPtr = NULL lindex [font actual {-family times}] 0 } {-family} -test font-4.9 {font command: actual} {macOrUnix noExceed} { +test font-4.9 {font command: actual} {unix noExceed} { # (objc > 3) so objPtr = objv[3 + skip] string tolower [font actual {-family times} -family] } {times} -test font-4.10 {font command: actual} {pcOnly} { +test font-4.10 {font command: actual} win { # (objc > 3) so objPtr = objv[3 + skip] font actual {-family times} -family } {Times New Roman} @@ -307,8 +307,8 @@ test font-8.4 {font command: families} { test font-9.1 {font command: measure: arguments} { # (skip < 0) - list [catch {font measure xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} + list [catch {expr {[font measure xyz -displayof]>0}} msg] $msg +} {0 1} test font-9.2 {font command: measure: arguments} { # (objc - skip != 4) list [catch {font measure} msg] $msg @@ -325,6 +325,15 @@ test font-9.5 {font command: measure} { # Tk_TextWidth() expr [font measure $fixed "abcdefg"]==[font measure $fixed "a"]*7 } {1} +test font-9.6 {font command: measure -d} { + list [catch {expr {[font measure $fixed -d] > 0}} msg] $msg +} {0 1} +test font-9.7 {font command: measure -d with -displayof} { + list [catch {expr {[font measure $fixed -displayof . -d] > 0}} msg] $msg +} {0 1} +test font-9.8 {font command: measure: arguments} { + list [catch {font measure $fixed -displayof .} msg] $msg +} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} test font-10.1 {font command: metrics: arguments} { list [catch {font metrics xyz -displayof} msg] $msg @@ -498,21 +507,16 @@ test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} { setup .b.f config -font {times 20} } {} -test font-15.7 {Tk_AllocFontFromObj procedure: get native font} {unixOnly} { +test font-15.7 {Tk_AllocFontFromObj procedure: get native font} unix { # not (fontPtr == NULL) setup .b.f config -font fixed } {} -test font-15.8 {Tk_AllocFontFromObj procedure: get native font} {pcOnly} { +test font-15.8 {Tk_AllocFontFromObj procedure: get native font} win { # not (fontPtr == NULL) setup .b.f config -font oemfixed } {} -test font-15.9 {Tk_AllocFontFromObj procedure: get native font} {macOnly} { - # not (fontPtr == NULL) - setup - .b.f config -font application -} {} test font-15.10 {Tk_AllocFontFromObj procedure: get attribute font} { # (fontPtr == NULL) list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg @@ -649,7 +653,7 @@ proc psfontname {name} { set start [string first "gsave" $post] return [string range $post [expr $start+7] end] } -test font-21.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { +test font-21.1 {Tk_PostscriptFontName procedure: native} unix { set x [font actual {{itc avant garde} 10} -family] if {[string match *avant*garde $x]} { psfontname "{itc avant garde} 10" @@ -657,25 +661,16 @@ test font-21.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { set x {AvantGarde-Book} } } {AvantGarde-Book} -test font-21.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.2 {Tk_PostscriptFontName procedure: native} win { psfontname "arial 10" } {Helvetica} -test font-21.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.3 {Tk_PostscriptFontName procedure: native} win { psfontname "{times new roman} 10" } {Times-Roman} -test font-21.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.4 {Tk_PostscriptFontName procedure: native} win { psfontname "{courier new} 10" } {Courier} -test font-21.5 {Tk_PostscriptFontName procedure: native} {macOnly} { - psfontname "geneva 10" -} {Helvetica} -test font-21.6 {Tk_PostscriptFontName procedure: native} {macOnly} { - psfontname "{new york} 10" -} {Times-Roman} -test font-21.7 {Tk_PostscriptFontName procedure: native} {macOnly} { - psfontname "monaco 10" -} {Courier} -test font-21.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { +test font-21.8 {Tk_PostscriptFontName procedure: spaces} unix { set x [font actual {{lucida bright} 10} -family] if {[string match lucida*bright $x]} { psfontname "{lucida bright} 10" @@ -683,80 +678,75 @@ test font-21.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { set x {LucidaBright} } } {LucidaBright} -test font-21.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { +test font-21.9 {Tk_PostscriptFontName procedure: spaces} unix { psfontname "{new century schoolbook} 10" } {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} unix { 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} win { 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] -} -foreach p { - {"courier" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {"geneva" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {"helvetica" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {"monaco" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {"new york" Times-Roman Times-Bold Times-Italic Times-BoldItalic} - {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} - {"times" Times-Roman Times-Bold Times-Italic Times-BoldItalic} -} { - test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {macOnly} { - set family [lindex $p 0] - 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} { @@ -1152,48 +1142,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} { @@ -1202,12 +1191,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 @@ -1216,19 +1207,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 @@ -1267,15 +1259,18 @@ test font-38.9 {ParseFontNameObj procedure: arguments} { test font-38.10 {ParseFontNameObj procedure: arguments} { list [catch {font actual {times xyz xyz}} msg] $msg } {1 {expected integer but got "xyz"}} -test font-38.11 {ParseFontNameObj procedure: stylelist loop} {macOnly} { - lrange [font actual {times 12 bold italic overstrike underline}] 4 end -} {-weight bold -slant italic -underline 1 -overstrike 0} test font-38.12 {ParseFontNameObj procedure: stylelist loop} {unixOrPc} { lrange [font actual {times 12 bold italic overstrike underline}] 4 end } {-weight bold -slant italic -underline 1 -overstrike 1} test font-38.13 {ParseFontNameObj procedure: stylelist error} { list [catch {font actual {times 12 bold xyz}} msg] $msg } {1 {unknown font style "xyz"}} +test font-38.14 "ParseFontNameObj: options with hyphenated family: bug #2791352" -body { + font actual {-family sans-serif -size 12 -weight bold -slant roman -underline 0 -overstrike 0} +} -returnCodes ok -result [font actual {sans-serif 12 bold}] +test font-38.15 "ParseFontNameObj: bug #2791352" -body { + font actual {-invalidfont 8 bold} +} -returnCodes error -match glob -result {bad option "-invalidfont": *} test font-39.1 {NewChunk procedure: test realloc} { .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" @@ -1344,35 +1339,48 @@ tk scaling $oldscale test font-45.1 {TkFontGetAliasList: no match} { font actual {snarky 10} -family } [font actual {-size 10} -family] -test font-45.2 {TkFontGetAliasList: match} {macOnly} { - # Result could be either "Times" or "New York" - font actual {{times new roman} 10} -family -} [font actual {times 10} -family] -test font-45.3 {TkFontGetAliasList: match} {pcOnly} { +test font-45.3 {TkFontGetAliasList: match} win { font actual {times 10} -family } {Times New Roman} -test font-45.4 {TkFontGetAliasList: match} {unixOnly noExceed} { +test font-45.4 {TkFontGetAliasList: match} {unix noExceed} { # can fail on Unix systems that have a real "times new roman" font font actual {{times new roman} 10} -family } [font actual {times 10} -family] +test font-46.1 {font actual, with character, no option, no --} \ + -body { + font actual {times 10} a + } \ + -match glob \ + -result [list -family [font actual {times 10} -family] -size *\ + -slant roman -underline 0 -overstrike 0] + +test font-46.2 {font actual, with character introduced by --} \ + -body { + font actual {times 10} -- - + } \ + -match glob \ + -result [list -family [font actual {times 10} -family] -size *\ + -slant roman -underline 0 -overstrike 0] + +test font-46.3 {font actual, with character and option} { + font actual {times 10} -family a +} [font actual {times 10} -family] + +test font-46.4 {font actual, with character, option and --} { + font actual {times 10} -family -- - +} [font actual {times 10} -family] + +test font-46.5 {font actual, too many chars} { + list [catch { + font actual {times 10} 123456789012345678901234567890123456789012345678901 + } result] $result +} {1 {expected a single character but got "1234567890123456789012345678901234567..."}} + setup destroy .b # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/frame.test b/tests/frame.test index 07258da..affdac6 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # eatColors -- @@ -121,23 +118,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 @@ -152,7 +148,7 @@ test frame-2.2 {toplevel configuration options} { } {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}} test frame-2.3 {toplevel configuration options} { catch {destroy .t} - toplevel .t -width 200 -height 100 -colormap {} -use {} + toplevel .t -width 200 -height 100 wm geometry .t +0+0 list [catch {.t configure -container 1} msg] $msg [.t configure -container] } {1 {can't modify -container option after widget is created} {-container container Container 0 0}} @@ -161,12 +157,22 @@ test frame-2.4 {toplevel configuration options} { list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg } {1 {bad window path name "bogus"}} set default "[winfo visual .] [winfo depth .]" +if {$tcl_platform(platform) == "windows"} { +test frame-2.5 {toplevel configuration options} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use] +} {1 {window "0x44022" doesn't exist} {-use use Use {} {}}} +} else { test frame-2.5 {toplevel configuration options} { catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use] } {1 {can't modify -use option after widget is created} {-use use Use {} {}}} +} + test frame-2.6 {toplevel configuration options} { catch {destroy .t} toplevel .t -width 200 -height 100 -visual default @@ -177,15 +183,14 @@ 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 + set cfg [string compare [.t configure -screen] \ + "-screen screen Screen {} $env(DISPLAY)"] + list $cfg [catch {.t configure -screen another} msg] $msg +} {0 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 @@ -235,39 +240,41 @@ 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} +} -result {-class class Class Toplevel Toplevel} test frame-3.4 {TkCreateFrame procedure} { catch {destroy .t} toplevel .t -width 350 -class NewClass -bg black -visual default -height 90 @@ -311,141 +318,148 @@ 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 unix -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 unix -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 +# The tests below require specific display characteristics (i.e. that +# they are run on a pseudocolor display of depth 8). 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 defaultPseudocolor8]} { 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} {defaultPseudocolor8 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} {defaultPseudocolor8 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} {defaultPseudocolor8 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} {defaultPseudocolor8 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 {defaultPseudocolor8 unix 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} {defaultPseudocolor8 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} {defaultPseudocolor8 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} {defaultPseudocolor8 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} {defaultPseudocolor8 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} {defaultPseudocolor8 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} {defaultPseudocolor8 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 defaultPseudocolor8]} { 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 @@ -454,20 +468,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} @@ -777,16 +791,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 @@ -796,7 +810,7 @@ destroy .f test frame-14.1 {labelframe labelwidget option} { # Test that label is moved in stacking order destroy .f .l - label .l -text Mupp + label .l -text Mupp -font {helvetica 8} labelframe .f -labelwidget .l pack .f frame .f.f -width 50 -height 50 @@ -897,5 +911,6 @@ rename eatColors {} rename colorsFree {} # cleanup -::tcltest::cleanupTests +cleanupTests return + diff --git a/tests/geometry.test b/tests/geometry.test index 9b3f253..04ab578 100644 --- a/tests/geometry.test +++ b/tests/geometry.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands wm geometry . 300x300 @@ -248,18 +245,5 @@ test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { catch {destroy .t} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/get.test b/tests/get.test index 66d0b2c..d3a4228 100644 --- a/tests/get.test +++ b/tests/get.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands button .b @@ -77,18 +74,5 @@ test get-2.4 {Tk_GetJustifyFromObj - error} { } {1 {bad justification "stupid": must be left, right, or center}} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/grab.test b/tests/grab.test index 35ac8cc..2f4f73b 100644 --- a/tests/grab.test +++ b/tests/grab.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # There's currently no way to test the actual grab effect, per se, @@ -179,5 +176,5 @@ test grab-5.2 {Tk_GrabObjCmd, grab set} { set result } [list "." "global"] -tcltest::cleanupTests +cleanupTests return diff --git a/tests/grid.test b/tests/grid.test index eb8cfe1..fee81b5 100644 --- a/tests/grid.test +++ b/tests/grid.test @@ -6,10 +6,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # helper routine to return "." to a sane state after a test @@ -35,6 +32,7 @@ proc grid_reset {{test ?} {top .}} { grid rowconfigure . $i -weight 0 -minsize 0 -pad 0 -uniform "" } grid propagate . 1 + grid anchor . nw update } @@ -47,7 +45,7 @@ test grid-1.1 {basic argument checking} { test grid-1.2 {basic argument checking} { list [catch {grid foo bar} msg] $msg -} {1 {bad option "foo": must be bbox, columnconfigure, configure, forget, info, location, propagate, remove, rowconfigure, size, or slaves}} +} {1 {bad option "foo": must be anchor, bbox, columnconfigure, configure, forget, info, location, propagate, remove, rowconfigure, size, or slaves}} test grid-1.3 {basic argument checking} { button .b @@ -164,7 +162,7 @@ grid_reset 3.2 test grid-3.3 {configure: basic argument checking} { button .b list [catch {grid .b -row -1} msg] $msg -} {1 {bad grid value "-1": must be a non-negative integer}} +} {1 {bad row value "-1": must be a non-negative integer}} grid_reset 3.3 test grid-3.4 {configure: basic argument checking} { @@ -583,7 +581,7 @@ grid_reset 10.3 test grid-10.4 {column/row configure} { list [catch {grid columnconfigure . nine -weight} msg] $msg -} {1 {expected integer but got "nine"}} +} {1 {expected integer but got "nine" (when retreiving options only integer indices are allowed)}} grid_reset 10.4 test grid-10.5 {column/row configure} { @@ -688,6 +686,69 @@ test grid-10.20 {column/row configure} { } {foo} grid_reset 10.20 +test grid-10.21 {column/row configure} { + list [catch {grid columnconfigure . .b -weight 1} msg] $msg +} {1 {grid columnconfigure: illegal index ".b"}} +grid_reset 10.21 + +test grid-10.22 {column/row configure} { + button .b + list [catch {grid columnconfigure . .b -weight 1} msg] $msg +} {1 {grid columnconfigure: the window ".b" is not managed by "."}} +grid_reset 10.22 + +test grid-10.23 {column/row configure} { + button .b + grid .b -column 1 -columnspan 2 + grid columnconfigure . .b -weight 1 + set res {} + foreach i {0 1 2 3} { + lappend res [grid columnconfigure . $i -weight] + } + set res +} {0 1 1 0} +grid_reset 10.23 + +test grid-10.24 {column/row configure} { + button .b + button .c + button .d + grid .b -column 1 -columnspan 2 + grid .c -column 2 -columnspan 3 + grid .d -column 4 -columnspan 2 + grid columnconfigure . {.b .d} -weight 1 + grid columnconfigure . .c -weight 2 + set res {} + foreach i {0 1 2 3 4 5 6} { + lappend res [grid columnconfigure . $i -weight] + } + set res +} {0 1 2 2 2 1 0} +grid_reset 10.24 + +test grid-10.25 {column/row configure} { + button .b + button .c + button .d + grid .b -row 1 -rowspan 2 + grid .c -row 2 -rowspan 3 + grid .d -row 4 -rowspan 2 + grid rowconfigure . {7 all} -weight 1 + grid rowconfigure . {1 .d} -weight 2 + set res {} + foreach i {0 1 2 3 4 5 6 7} { + lappend res [grid rowconfigure . $i -weight] + } + set res +} {0 2 1 1 2 2 0 1} +grid_reset 10.25 + +test grid-10.26 {column/row configure} { + button .b + grid columnconfigure .b 0 +} {-minsize 0 -pad 0 -uniform {} -weight 0} +grid_reset 10.26 + test grid-10.30 {column/row configure - no indices} { # Bug 1422430 set t [toplevel .test] @@ -711,6 +772,33 @@ test grid-10.33 {column/row configure - invalid indices} { list [catch {grid rowconfigure . {0 1 2} -weight} msg] $msg } {1 {grid rowconfigure: must specify a single element on retrieval}} +test grid-10.34 {column/row configure - empty 'all' configure} { + # Bug 1422430 + set t [toplevel .test] + grid rowconfigure $t all -weight 1 + destroy $t +} {} + +test grid-10.35 {column/row configure} { + # Test that no lingering message is there + frame .f + set res [grid columnconfigure .f all -weight 1] + append res [grid columnconfigure .f {0 all} -weight 1] + frame .f.f + grid .f.f + append res [grid columnconfigure .f {.f.f} -weight 1] + append res [grid columnconfigure .f {.f.f 1} -weight 1] + append res [grid columnconfigure .f {2 .f.f} -weight 1] + destroy .f + set res +} {} +grid_reset 10.35 + +test grid-10.36 {column/row configure} { + list [catch {grid columnconfigure . all} msg] $msg +} {1 {expected integer but got "all" (when retreiving options only integer indices are allowed)}} +grid_reset 10.36 + test grid-10.37 {column/row configure} { list [catch {grid columnconfigure . 100000} msg] $msg } {0 {-minsize 0 -pad 0 -uniform {} -weight 0}} @@ -722,14 +810,11 @@ test grid-10.38 {column/row configure} -body { # Test different combinations of row/column overflow frame .f set res {} - grid .f -column 0 -columnspan 1 -row 0 -rowspan 1 lappend res [catch {grid .f -row 10 -column 9999} msg] $msg ; update lappend res [catch {grid .f -row 9999 -column 10} msg] $msg ; update lappend res [catch {grid .f -columnspan 2 -column 9998} msg] $msg ; update lappend res [catch {grid .f -rowspan 2 -row 9998} msg] $msg ; update - grid .f -column 0 -columnspan 1 -row 0 -rowspan 1 lappend res [catch {grid .f -column 9998 -columnspan 2} msg] $msg ; update - grid .f -column 0 -columnspan 1 -row 0 -rowspan 1 lappend res [catch {grid .f -row 9998 -rowspan 2} msg] $msg ; update set res } -cleanup {destroy .f} -result [lrange { @@ -748,8 +833,7 @@ test grid-10.39 {column/row configure} -body { frame .g set res {} grid .f -row 9998 -column 0 - lappend res [catch {grid ^ .g} msg] $msg ; update - grid forget .g + lappend res [catch {grid ^ -in .} msg] $msg ; update lappend res [catch {grid .g} msg] $msg ; update grid forget .f .g lappend res [catch {grid .f - -column 9998} msg] $msg ; update @@ -966,6 +1050,41 @@ test grid-11.17 {default widget placement} { } {100 50 100} grid_reset 11.17 +test grid-11.18 {default widget placement} { + foreach l {a b c d e} { + frame .$l -width 50 -height 50 + } + grid .a .b .c .d -sticky news + grid ^ ^ ^ x -in . ;# ^ and no child should work with -in. + grid rowconfigure . {0 1} -uniform a + update + set res "" + lappend res [winfo height .a] + lappend res [winfo height .b] + lappend res [winfo height .c] + lappend res [winfo height .d] +} {100 100 100 50} +grid_reset 11.18 + +test grid-11.19 {default widget placement} { + foreach l {a b c d e} { + frame .$l -width 50 -height 50 + } + grid .a .b -sticky news + grid .c .d -sticky news + grid ^ -in . -row 2 + grid x ^ -in . -row 1 + + grid rowconfigure . {0 1 2} -uniform a + update + set res "" + lappend res [winfo height .a] + lappend res [winfo height .b] + lappend res [winfo height .c] + lappend res [winfo height .d] +} {50 100 100 50} +grid_reset 11.19 + test grid-12.1 {-sticky} { catch {unset data} frame .f -width 200 -height 100 -highlightthickness 0 -bg red @@ -1021,6 +1140,14 @@ test grid-13.1 {-in} { } {1 {Window can't be managed in itself}} grid_reset 13.1 +test grid-13.1.1 {-in} { + frame .f -bg red + list [winfo manager .f] \ + [catch {grid .f -in .f} err] $err \ + [winfo manager .f] +} {{} 1 {Window can't be managed in itself} {}} +grid_reset 13.1.1 + test grid-13.2 {-in} { frame .f -bg red list [catch "grid .f -in .bad" msg] $msg @@ -1268,6 +1395,7 @@ test grid-16.1 {layout centering} { grid .$i -row $i -column $i -sticky nswe } grid propagate . 0 + grid anchor . center . configure -width 300 -height 250 update grid bbox . @@ -1419,7 +1547,7 @@ test grid-16.8 {layout internal constraints} { append a "[winfo x .$i] " } set a -} {0 30 70 250 280 , 0 30 130 230 260 , 0 30 113 197 280 , 0 30 60 90 120 } +} {0 30 130 230 280 , 0 30 130 230 260 , 0 30 113 196 280 , 0 30 60 90 120 } grid_reset 16.8 test grid-16.9 {layout uniform} { @@ -1484,7 +1612,7 @@ test grid-16.12 {layout uniform (grow)} { grid .f1 .f2 .f3 .f4 -sticky news grid columnconfigure . {0 1 2} -uniform a # Put weight 2 on the biggest in the group to see that the groups - # adapts to one of the smaller. + # adapt to one of the smaller. grid columnconfigure . 2 -weight 2 grid columnconfigure . {0 3} -weight 1 update @@ -1501,7 +1629,113 @@ test grid-16.12 {layout uniform (grow)} { {0 0 70 95} {70 0 50 95} {120 0 140 95} {260 0 90 95}] grid_reset 16.12 -test grid-16.13 {layout weights (shrinking at minsize)} { +test grid-16.13 {layout span} { + frame .f1 -width 24 -height 20 + frame .f2 -width 38 -height 20 + frame .f3 -width 150 -height 20 + + grid .f1 - - .f2 + grid .f3 - - - + + set res {} + foreach w {{0 1 0 0} {0 0 1 0} {1 3 4 0} {1 2 1 2} {1 1 1 12}} { + for {set c 0} {$c < 4} {incr c} { + grid columnconfigure . $c -weight [lindex $w $c] + } + update + set res2 {} + for {set c 0} {$c <= 4} {incr c} { + lappend res2 [lindex [grid bbox . $c 0] 2] + } + lappend res $res2 + } + set res + # The last result below should ideally be 8 8 8 126 but the current + # implementation is not exact enough. +} [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ + [list 18 38 18 76 0] [list 7 8 9 126 0]] +grid_reset 16.13 + +test grid-16.14 {layout span} { + frame .f1 -width 110 -height 20 + frame .f2 -width 38 -height 20 + frame .f3 -width 150 -height 20 + + grid .f1 - - .f2 + grid .f3 - - - + + set res {} + foreach w {{0 1 0 0} {0 0 1 0} {1 3 4 0} {1 2 1 3} {1 1 1 12}} { + for {set c 0} {$c < 4} {incr c} { + grid columnconfigure . $c -weight [lindex $w $c] + } + update + set res2 {} + for {set c 0} {$c <= 4} {incr c} { + lappend res2 [lindex [grid bbox . $c 0] 2] + } + lappend res $res2 + } + set res +} [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ + [list 27 55 28 40 0] [list 36 37 37 40 0]] +grid_reset 16.14 + +test grid-16.15 {layout span} { + frame .f1 -width 24 -height 20 + frame .f2 -width 38 -height 20 + frame .f3 -width 150 -height 20 + + grid .f1 - - .f2 + grid x .f3 - - + + set res {} + foreach w {{0 1 0 0} {0 0 1 0} {1 0 1 0} {0 0 0 0} {1 0 0 6}} { + for {set c 0} {$c < 4} {incr c} { + grid columnconfigure . $c -weight [lindex $w $c] + } + update + set res2 {} + for {set c 0} {$c <= 4} {incr c} { + lappend res2 [lindex [grid bbox . $c 0] 2] + } + lappend res $res2 + } + set res +} [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 0 0 112 38 0] \ + [list 0 37 37 76 0] [list 0 12 12 126 0]] +grid_reset 16.15 + +test grid-16.16 {layout span} { + frame .f1 -width 64 -height 20 + frame .f2 -width 38 -height 20 + frame .f3 -width 150 -height 20 + frame .f4 -width 15 -height 20 + frame .f5 -width 18 -height 20 + frame .f6 -width 20 -height 20 + + grid .f1 - x .f2 + grid .f3 - - - + grid .f4 .f5 .f6 + + set res {} + foreach w {{1 1 5 1} {0 0 1 0} {1 3 4 0} {1 2 1 2} {1 1 1 12}} { + for {set c 0} {$c < 4} {incr c} { + grid columnconfigure . $c -weight [lindex $w $c] + } + update + set res2 {} + for {set c 0} {$c <= 4} {incr c} { + lappend res2 [lindex [grid bbox . $c 0] 2] + } + lappend res $res2 + } + set res +} [list [list 30 34 43 43 0] [list 30 34 48 38 0] [list 22 42 48 38 0] \ + [list 25 39 29 57 0] [list 30 34 22 64 0]] +grid_reset 16.16 + +test grid-16.17 {layout weights (shrinking at minsize)} { foreach i {0 1 2 3} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1522,8 +1756,33 @@ test grid-16.13 {layout weights (shrinking at minsize)} { } set a } {25-25-1 25-25-1 100-75-1 100-75-1 25-25-0 25-25-0 100-75-1 100-75-1} -grid_reset 16.13 +grid_reset 16.17 +test grid-16.18 {layout span} { + frame .f1 -width 30 -height 20 + frame .f2 -width 166 -height 20 + frame .f3 -width 39 -height 20 + frame .f4 -width 10 -height 20 + + grid .f1 .f3 - + grid .f2 - .f4 + grid columnconfigure . 0 -weight 1 + + set res {} + foreach w {{1 0 0} {0 1 0} {0 0 1}} { + for {set c 0} {$c < 3} {incr c} { + grid columnconfigure . $c -weight [lindex $w $c] + } + update + set res2 {} + for {set c 0} {$c <= 2} {incr c} { + lappend res2 [lindex [grid bbox . $c 0] 2] + } + lappend res $res2 + } + set res +} [list [list 137 29 10] [list 30 136 10] [list 98 68 10]] +grid_reset 16.18 test grid-17.1 {forget and pending idle handlers} { # This test is intended to detect a crash caused by a failure to remove @@ -1616,6 +1875,141 @@ test grid-20.2 {recalculate size after removal (forget)} { } {1 1} grid_reset 20.2 +test grid-21.1 {anchor} { + list [catch {grid anchor . 1 xxx} msg] $msg +} {1 {wrong # args: should be "grid anchor window ?anchor?"}} +grid_reset 21.1 + +test grid-21.2 {anchor} { + list [catch {grid anchor .} msg] $msg +} {0 nw} +grid_reset 21.2 + +test grid-21.3 {anchor} { + list [catch {grid anchor . se;grid anchor .} msg] $msg +} {0 se} +grid_reset 21.3 + +test grid-21.4 {anchor} { + list [catch {grid anchor .x} msg] $msg +} {1 {bad window path name ".x"}} +grid_reset 21.4 + +test grid-21.5 {anchor} { + list [catch {grid anchor . x} msg] $msg +} {1 {bad anchor "x": must be n, ne, e, se, s, sw, w, nw, or center}} +grid_reset 21.5 + +test grid-21.6 {anchor} { + foreach i {0 1 2} { + frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe + } + grid propagate . 0 + . configure -width 300 -height 250 + + set res {} + foreach a {n ne e se s sw w nw center} { + grid anchor . $a + update + lappend res [grid bbox .] + } + set res +} [list {37 0 225 150} {75 0 225 150} {75 50 225 150} {75 100 225 150} \ + {37 100 225 150} {0 100 225 150} {0 50 225 150} {0 0 225 150} \ + {37 50 225 150}] +grid_reset 21.6 + +test grid-21.7 {anchor} { + # Test with a non-symmetric internal border. + # This only tests vertically, there is currently no way to get + # it assymetric horizontally. + labelframe .f -bd 0 + frame .f.x -width 20 -height 20 + .f configure -labelwidget .f.x + pack .f -fill both -expand 1 + + foreach i {0 1 2} { + frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge + grid .$i -in .f -row $i -column $i -sticky nswe + } + pack propagate . 0 + grid propagate .f 0 + . configure -width 300 -height 250 + + set res {} + foreach a {n ne e se s sw w nw center} { + grid anchor .f $a + update + lappend res [grid bbox .f] + } + pack propagate . 1 ; wm geometry . {} + set res +} [list {37 20 225 150} {75 20 225 150} {75 60 225 150} {75 100 225 150} \ + {37 100 225 150} {0 100 225 150} {0 60 225 150} {0 20 225 150} \ + {37 60 225 150}] +grid_reset 21.7 + +test grid-22.1 {remove: basic argument checking} { + list [catch {grid remove foo} msg] $msg +} {1 {bad window path name "foo"}} + +test grid-22.2 {remove} { + button .c + grid [button .b] + set a [grid slaves .] + grid remove .b .c + lappend a [grid slaves .] + set a +} {.b {}} +grid_reset 22.2 + +test grid-22.3 {remove} { + button .c + grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns + grid remove .c + grid .c -row 0 -column 0 + grid info .c +} {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx 3 -pady 4 -sticky ns} +grid_reset 22.3 + +test grid-22.3.1 {remove} { + frame .a + button .c + grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns + grid remove .c + grid .c -row 0 -column 0 + grid info .c +} {-in .a -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns} +grid_reset 22.3.1 + +test grid-22.4 {remove, calling Tk_UnmaintainGeometry} { + frame .f -bd 2 -relief raised + place .f -x 10 -y 20 -width 200 -height 100 + frame .f2 -width 50 -height 30 -bg red + grid .f2 -in .f + update + set x [winfo ismapped .f2] + grid remove .f2 + place .f -x 30 + update + lappend x [winfo ismapped .f2] +} {1 0} +grid_reset 22.4 + +test grid-22.5 {remove} { + frame .a + button .c + grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns + grid remove .c + # If .a was destroyed while remembered by the removed .c, make sure it + # is ignored. + destroy .a + grid .c -row 0 -column 0 + grid info .c +} {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns} +grid_reset 22.5 + # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/id.test b/tests/id.test index 670f27f..de0d965 100644 --- a/tests/id.test +++ b/tests/id.test @@ -7,13 +7,10 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -test id-1.1 {WindowIdCleanup, delaying window release} {unixOnly testwrapper} { +test id-1.1 {WindowIdCleanup, delaying window release} {unix testwrapper} { bind all <Destroy> {lappend x %W} catch {unset map} frame .f @@ -90,18 +87,5 @@ test id-1.1 {WindowIdCleanup, delaying window release} {unixOnly testwrapper} { bind all <Destroy> {} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/image.test b/tests/image.test index 2430b6e..c6c4f8a 100644 --- a/tests/image.test +++ b/tests/image.test @@ -8,15 +8,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands - -namespace import -force tcltest::interpreter -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile +namespace import -force ::tk::test::loadTkCommand eval image delete [image names] canvas .c -highlightthickness 2 @@ -72,26 +66,30 @@ test image-1.9 {Tk_ImageCmd procedure, "create" option} testImageType { list [catch {image create test -badName foo} msg] $msg [image names] } {1 {bad option name "-badName"} {}} test image-1.10 {Tk_ImageCmd procedure, "create" option with same name as main window} { - set script [makeFile { + set code [loadTkCommand] + append code { update puts [list [catch {image create photo .} msg] $msg] exit - } script] + } + set script [makeFile $code script] set x [list [catch {exec [interpreter] <$script} msg] $msg] removeFile script set x } {0 {1 {images may not be named the same as the main window}}} test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} { - set script [makeFile { + set code [loadTkCommand] + append code { update puts [list [catch {rename . foo;image create photo foo} msg] $msg] exit - } script] + } + set script [makeFile $code script] set x [list [catch {exec [interpreter] <$script} msg] $msg] removeFile script set x } {0 {1 {images may not be named the same as the main window}}} -test image-1.11 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { +test image-1.12 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { set i [image create bitmap] regexp {^image(\d+)$} $i -> serial incr serial @@ -175,15 +173,25 @@ test image-5.5 {Tk_ImageCmd procedure, "type" option} testImageType { image create test myimage .c create image 50 50 -image myimage image delete myimage + list [catch {image type myimage} msg] $msg +} {1 {image "myimage" doesn't exist}} +test image-5.6 {Tk_ImageCmd procedure, "type" option} testOldImageType { + image create oldtest myimage image type myimage -} {} +} {oldtest} +test image-5.7 {Tk_ImageCmd procedure, "type" option} testOldImageType { + image create oldtest myimage + .c create image 50 50 -image myimage + image delete myimage + list [catch {image type myimage} msg] $msg +} {1 {image "myimage" doesn't exist}} test image-6.1 {Tk_ImageCmd procedure, "types" option} { list [catch {image types x} msg] $msg } {1 {wrong # args: should be "image types"}} test image-6.2 {Tk_ImageCmd procedure, "types" option} testImageType { lsort [image types] -} {bitmap photo test} +} {bitmap oldtest photo test} test image-7.1 {Tk_ImageCmd procedure, "width" option} { list [catch {image width} msg] $msg @@ -271,16 +279,17 @@ test image-11.2 {Tk_FreeImage procedure} testImageType { eval image delete [image names] image create test foo -variable x .c create image 50 50 -image foo -tags i1 + set names [image names] image delete foo update - set names [image names] + set names2 [image names] set x {} .c delete i1 pack forget .c pack .c update - list $names [image names] $x -} {foo {} {}} + list $names $names2 [image names] $x +} {foo {} {} {}} # Non-portable, apparently due to differences in rounding: @@ -373,10 +382,28 @@ test image-13.2 {DeleteImage procedure} testImageType { .c create image 90 100 -image foo -tags i2 set x {} image delete foo - lappend x | [image names] | + lappend x | [image names] | [catch {image delete foo} msg] | $msg | [image names] | +} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} + +test image-13.3 {Tk_SizeOfImage procedure} testOldImageType { + eval image delete [image names] + image create oldtest foo -variable x + set result [list [image width foo] [image height foo]] + foo changed 0 0 0 0 85 60 + lappend result [image width foo] [image height foo] +} {30 15 85 60} + +test image-13.4 {DeleteImage procedure} testOldImageType { + .c delete all + eval image delete [image names] + image create oldtest foo -variable x + .c create image 50 50 -image foo -tags i1 + .c create image 90 100 -image foo -tags i2 + set x {} image delete foo - lappend x | [image names] | -} {{foo free} {foo free} {foo delete} | foo | | foo |} + lappend x | [image names] | [catch {image delete foo} msg] | $msg | [image names] | +} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} + catch {image delete hidden} set l [image names] @@ -389,10 +416,24 @@ test image-14.1 {image command vs hidden commands} { image delete hidden list [image names] [interp hidden] } [list $l $h] + +eval image delete [image names] +test image-15.1 {deleting image does not make widgets forget about it} { + .c delete all + image create photo foo -width 10 -height 10 + .c create image 10 10 -image foo -tags i1 -anchor nw + update + set x [.c bbox i1] + lappend x [image names] + image delete foo + lappend x [image names] + image create photo foo -width 20 -height 20 + lappend x [.c bbox i1] [image names] +} {10 10 20 20 foo {} {10 10 30 30} foo} destroy .c eval image delete [image names] # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/imgBmap.test b/tests/imgBmap.test index 06d8265..edbb8c3 100644 --- a/tests/imgBmap.test +++ b/tests/imgBmap.test @@ -8,15 +8,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile - set data1 {#define foo_width 16 #define foo_height 16 #define foo_x_hot 3 @@ -471,18 +465,5 @@ destroy .c eval image delete [image names] # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/imgPPM.test b/tests/imgPPM.test index 160f2f2..a9e9dc0 100644 --- a/tests/imgPPM.test +++ b/tests/imgPPM.test @@ -7,17 +7,13 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile - eval image delete [image names] +# Note that we do not use [tcltest::makeFile] because it is +# only suitable for text files proc put {file data} { set f [open $file w] fconfigure $f -translation lf @@ -72,8 +68,8 @@ test imgPPM-2.1 {FileWritePPM procedure} { } {1 {couldn't open "not_a_dir/bar/baz/gorp": no such file or directory} {posix enoent {no such file or directory}}} test imgPPM-2.2 {FileWritePPM procedure} { catch {unset data} - p1 write -format ppm test2.ppm - set fd [open test2.ppm] + p1 write -format ppm test.ppm + set fd [open test.ppm] set data [read $fd] close $fd set data @@ -161,23 +157,9 @@ test imgPPM-4.1 {StringReadPPM procedure, data too short [Bug 1822391]} \ -returnCodes error \ -result {truncated PPM data} -removeFile test.ppm -removeFile test2.ppm eval image delete [image names] # cleanup -::tcltest::cleanupTests +catch {file delete test.ppm} +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test index 79fede0..d4118b0 100644 --- a/tests/imgPhoto.test +++ b/tests/imgPhoto.test @@ -10,15 +10,9 @@ # Author: Paul Mackerras (paulus@cs.anu.edu.au) package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile - eval image delete [image names] canvas .c @@ -27,20 +21,11 @@ update set README [makeFile { README -- Tk test suite design document. -} README-imgPhotot] +} README-imgPhoto] # find the teapot.ppm file for use in these tests -# first look in $tk_library/demos/images/teapot.ppm -# then look in <this file>/../../library/demos/images/teapot.ppm -testConstraint hasTeapotPhoto 1 -set teapotPhotoFile [file join $tk_library demos images teapot.ppm] -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 - } -} +set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] +testConstraint hasTeapotPhoto [file exists $teapotPhotoFile] test imgPhoto-1.1 {options for photo images} { image create photo p1 -width 79 -height 83 @@ -412,7 +397,7 @@ proc checkImgTransLoopResetSet {img width height} { } return $result } -test imgPhoto-4.68 {ImgPhotoCmd procedure: transparency set option} { +test imgPhoto-4.67a {ImgPhotoCmd procedure: transparency set option} { checkImgTransLoopResetSet p1 3 3 } {0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 .} catch {rename checkImgTransLoopSetReset {}} @@ -571,7 +556,7 @@ test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} hasTeapotPhoto { } {{19 92 192} {169 117 90} 512 512 {19 92 192}} test imgPhoto-13.1 {check separation of images in different interpreters} { - eval image delete [image names] + image delete {*}[image names] set data { R0lGODlhQgBkAPUAANbWxs7Wxs7OxsbOxsbGxsbGvb3Gvca9vcDAwL21vbW1vbW1tbWtta2t ta2ltaWltaWlraWctaWcrZycrZyUrZSUrZSMrZSMpYyMrYyMpYyEpYSEpYR7pYR7nHp7pYRz @@ -614,7 +599,6 @@ test imgPhoto-13.1 {check separation of images in different interpreters} { interp delete x2 } {} - test imgPhoto-14.1 {GIF writes work correctly} { set data "R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM hASs3MTcjAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA @@ -657,10 +641,10 @@ test imgPhoto-14.2 {GIF -index handler buffer sizing} -setup { # Bug 1458234 makes this crash when trying to access buffers of the # wrong size, caused when the initial frame is not the largest frame. set data { - R0lGODlhIAAgAKEAAPkOSQsi7////////yH/C05FVFNDQVBFMi4wAwEAAAAh - +QQJMgAAACwGAAYAFAAUAAACEYyPqcvtD6OctNqLs968+68VACH5BAkyAAEA - LAMAAwAaABoAAAI0jH+gq+gfmFzQzUsr3gBybn1gIm5kaUaoubbuC8fyTNel - Ohv1CSO533u8KrgbUfc5Ci/EAgA7 + R0lGODlhIAAgAKEAAPkOSQsi7////////yH/C05FVFNDQVBFMi4wAwEAAAAh + +QQJMgAAACwGAAYAFAAUAAACEYyPqcvtD6OctNqLs968+68VACH5BAkyAAEA + LAMAAwAaABoAAAI0jH+gq+gfmFzQzUsr3gBybn1gIm5kaUaoubbuC8fyTNel + Ohv1CSO533u8KrgbUfc5Ci/EAgA7 } $i configure -data $data -format {gif -index 2} } -cleanup { @@ -728,5 +712,5 @@ eval image delete [image names] # cleanup removeFile README-imgPhoto -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/listbox.test b/tests/listbox.test index fd8603d..25bc606 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -7,17 +7,14 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands set fixed {Courier -12} -proc record args { +proc record {name args} { global log - lappend log $args + lappend log [format {%s %.6g %.6g} $name {*}$args] } proc getsize w { @@ -477,7 +474,7 @@ test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} {fonts} { .t.l scan mark 100 140 .t.l scan dragto 90 137 update - list [.t.l xview] [.t.l yview] + list [format {%.6g %.6g} {*}[.t.l xview]] [format {%.6g %.6g} {*}[.t.l yview]] } {{0.249364 0.427481} {0.0714286 0.428571}} test listbox-3.79 {ListboxWidgetCmd procedure, "scan" option} { list [catch {.l scan foo 2 4} msg] $msg @@ -629,7 +626,7 @@ test listbox-3.114 {ListboxWidgetCmd procedure, "xview" option} { catch {destroy .l2} listbox .l2 update - .l2 xview + format {%.6g %.6g} {*}[.l2 xview] } {0 1} test listbox-3.115 {ListboxWidgetCmd procedure, "xview" option} { catch {destroy .l} @@ -637,7 +634,7 @@ test listbox-3.115 {ListboxWidgetCmd procedure, "xview" option} { .l insert 0 a b c d e f g h i j k l m n o p q r s t pack .l update - .l xview + format {%.6g %.6g} {*}[.l xview] } {0 1} catch {destroy .l} listbox .l -width 10 -height 5 -font $fixed @@ -647,7 +644,7 @@ pack .l update test listbox-3.116 {ListboxWidgetCmd procedure, "xview" option} {fonts} { .l xview 4 - .l xview + format {%.6g %.6g} {*}[.l xview] } {0.08 0.28} test listbox-3.117 {ListboxWidgetCmd procedure, "xview" option} { list [catch {.l xview foo} msg] $msg @@ -659,19 +656,19 @@ test listbox-3.119 {ListboxWidgetCmd procedure, "xview" option} {fonts} { .l xview 0 .l xview moveto .4 update - .l xview + format {%.6g %.6g} {*}[.l xview] } {0.4 0.6} test listbox-3.120 {ListboxWidgetCmd procedure, "xview" option} {fonts} { .l xview 0 .l xview scroll 2 units update - .l xview + format {%.6g %.6g} {*}[.l xview] } {0.04 0.24} test listbox-3.121 {ListboxWidgetCmd procedure, "xview" option} {fonts} { .l xview 30 .l xview scroll -1 pages update - .l xview + format {%.6g %.6g} {*}[.l xview] } {0.44 0.64} test listbox-3.122 {ListboxWidgetCmd procedure, "xview" option} {fonts} { .l configure -width 1 @@ -679,14 +676,14 @@ test listbox-3.122 {ListboxWidgetCmd procedure, "xview" option} {fonts} { .l xview 30 .l xview scroll -4 pages update - .l xview + format {%.6g %.6g} {*}[.l xview] } {0.52 0.54} test listbox-3.123 {ListboxWidgetCmd procedure, "yview" option} { catch {destroy .l} listbox .l pack .l update - .l yview + format {%.6g %.6g} {*}[.l yview] } {0 1} test listbox-3.124 {ListboxWidgetCmd procedure, "yview" option} { catch {destroy .l} @@ -694,7 +691,7 @@ test listbox-3.124 {ListboxWidgetCmd procedure, "yview" option} { .l insert 0 el1 pack .l update - .l yview + format {%.6g %.6g} {*}[.l yview] } {0 1} catch {destroy .l} listbox .l -width 10 -height 5 -font $fixed @@ -704,11 +701,11 @@ update test listbox-3.125 {ListboxWidgetCmd procedure, "yview" option} { .l yview 4 update - .l yview + format {%.6g %.6g} {*}[.l yview] } {0.2 0.45} test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last line} { mkPartial - .partial.l yview + format {%.6g %.6g} {*}[.partial.l yview] } {0 0.266667} test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} { list [catch {.l yview foo} msg] $msg @@ -719,24 +716,24 @@ test listbox-3.128 {ListboxWidgetCmd procedure, "xview" option} { test listbox-3.129 {ListboxWidgetCmd procedure, "xview" option} { .l yview 0 .l yview moveto .31 - .l yview + format {%.6g %.6g} {*}[.l yview] } {0.3 0.55} test listbox-3.130 {ListboxWidgetCmd procedure, "xview" option} { .l yview 2 .l yview scroll 2 pages - .l yview + format {%.6g %.6g} {*}[.l yview] } {0.4 0.65} test listbox-3.131 {ListboxWidgetCmd procedure, "xview" option} { .l yview 10 .l yview scroll -3 units - .l yview + format {%.6g %.6g} {*}[.l yview] } {0.35 0.6} test listbox-3.132 {ListboxWidgetCmd procedure, "xview" option} { .l configure -height 2 update .l yview 15 .l yview scroll -4 pages - .l yview + format {%.6g %.6g} {*}[.l yview] } {0.55 0.65} test listbox-3.133 {ListboxWidgetCmd procedure, "xview" option} { list [catch {.l whoknows} msg] $msg @@ -944,6 +941,7 @@ test listbox-4.18 {ConfigureListbox, no listvar -> bad listvar} { "unmatched open quote in list: invalid -listvariable value"] test listbox-4.19 {ConfigureListbox, no listvar -> bad non-existent listvar} { catch {destroy .l} + unset -nocomplain ::foo listbox .l -listvar foo .l insert end a b c d catch {.l configure -listvar ::zoo::bar::foo} result @@ -1107,7 +1105,7 @@ test listbox-6.14 {InsertEls procedure, check selection update} { .l2 insert 0 a .l2 curselection } [list 3 4 5] -test listbox-6.15 {InsertEls procedure, lost namespaced listvar, bug 1424513} { +test listbox-6.15 {InsertEls procedure, lost namespaced listvar} { destroy .l2 namespace eval test { variable foo {a b} } listbox .l2 -listvar ::test::foo @@ -1302,7 +1300,7 @@ test listbox-8.2 {ListboxEventProc procedure} {fonts} { update place .l -width 50 -height 80 update - list [.l xview] [.l yview] + list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] } {{0 0.222222} {0 0.333333}} test listbox-8.3 {ListboxEventProc procedure} { deleteWindows @@ -1445,7 +1443,7 @@ test listbox-11.3 {ChangeListboxView procedure} { set log {} .l yview 2 update - list [.l yview] $log + list [format {%.6g %.6g} {*}[.l yview]] $log } {{0.2 0.7} {{y 0.2 0.7}}} test listbox-11.4 {ChangeListboxView procedure} { catch {destroy .l} @@ -1456,7 +1454,7 @@ test listbox-11.4 {ChangeListboxView procedure} { set log {} .l yview 8 update - list [.l yview] $log + list [format {%.6g %.6g} {*}[.l yview]] $log } {{0.5 1} {{y 0.5 1}}} test listbox-11.5 {ChangeListboxView procedure} { catch {destroy .l} @@ -1468,7 +1466,7 @@ test listbox-11.5 {ChangeListboxView procedure} { set log {} .l yview 3 update - list [.l yview] $log + list [format {%.6g %.6g} {*}[.l yview]] $log } {{0.3 0.8} {}} test listbox-11.6 {ChangeListboxView procedure, partial last line} { mkPartial @@ -1485,13 +1483,13 @@ test listbox-12.1 {ChangeListboxOffset procedure} {fonts} { set log {} .l xview 99 update - list [.l xview] $log + list [format {%.6g %.6g} {*}[.l xview]] $log } {{0.9 1} {{x 0.9 1}}} test listbox-12.2 {ChangeListboxOffset procedure} {fonts} { set log {} .l xview moveto -.25 update - list [.l xview] $log + list [format {%.6g %.6g} {*}[.l xview]] $log } {{0 0.1} {{x 0 0.1}}} test listbox-12.3 {ChangeListboxOffset procedure} {fonts} { .l xview 10 @@ -1499,7 +1497,7 @@ test listbox-12.3 {ChangeListboxOffset procedure} {fonts} { set log {} .l xview 10 update - list [.l xview] $log + list [format {%.6g %.6g} {*}[.l xview]] $log } {{0.1 0.2} {}} catch {destroy .l} @@ -1516,7 +1514,7 @@ test listbox-13.1 {ListboxScanTo procedure} {fonts} { .l scan mark 10 20 .l scan dragto [expr 10-$width] [expr 20-$height] update - list [.l xview] [.l yview] + list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] } {{0.2 0.4} {0.5 0.75}} test listbox-13.2 {ListboxScanTo procedure} {fonts} { .l yview 5 @@ -1524,10 +1522,10 @@ test listbox-13.2 {ListboxScanTo procedure} {fonts} { .l scan mark 10 20 .l scan dragto 20 40 update - set x [list [.l xview] [.l yview]] + set x [list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]] .l scan dragto [expr 20-$width] [expr 40-$height] update - lappend x [.l xview] [.l yview] + lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] } {{0 0.2} {0 0.25} {0.2 0.4} {0.5 0.75}} test listbox-13.3 {ListboxScanTo procedure} {fonts} { .l yview moveto 1.0 @@ -1535,10 +1533,10 @@ test listbox-13.3 {ListboxScanTo procedure} {fonts} { .l scan mark 10 20 .l scan dragto 5 10 update - set x [list [.l xview] [.l yview]] + set x [list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]] .l scan dragto [expr 5+$width] [expr 10+$height] update - lappend x [.l xview] [.l yview] + lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] } {{0.8 1} {0.75 1} {0.64 0.84} {0.25 0.5}} test listbox-14.1 {NearestListboxElement procedure, partial last line} { @@ -1723,7 +1721,7 @@ test listbox-18.3 {ListboxUpdateVScrollbar procedure} { set x } {{{invalid command name "gorp"}} {invalid command name "gorp" while executing -"gorp 0 1" +"gorp 0.0 1.0" (vertical scrolling command executed by listbox)}} if {[info exists bgerror]} { rename bgerror {} @@ -1755,7 +1753,7 @@ test listbox-19.2 {ListboxUpdateVScrollbar procedure} { set x } {{{invalid command name "bogus"}} {invalid command name "bogus" while executing -"bogus 0 1" +"bogus 0.0 1.0" (horizontal scrolling command executed by listbox)}} set l [interp hidden] @@ -1877,7 +1875,7 @@ test listbox-21.12 {ListboxListVarProc, cleanup item attributes} { set x [list 0 1 2 3 4 5 6] .l itemcget end -fg } {} -test listbox-21.12 {ListboxListVarProc, cleanup item attributes} { +test listbox-21.12a {ListboxListVarProc, cleanup item attributes} { catch {destroy .l} set x [list a b c d e f g] listbox .l -listvar x @@ -1925,12 +1923,12 @@ test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} { .l yview scroll 3 units update set result {} - lappend result [.l yview] + lappend result [format {%.6g %.6g} {*}[.l yview]] set x [lreplace $x 3 3] set x [lreplace $x 3 3] set x [lreplace $x 3 3] update - lappend result [.l yview] + lappend result [format {%.6g %.6g} {*}[.l yview]] set result } [list {0.5 1} {0 1}] @@ -2043,7 +2041,7 @@ test listbox-24.3 {itemcget} { catch {.l itemcget 0} result set result } {wrong # args: should be ".l itemcget index option"} -test listbox-24.3 {itemcget, itemcg shortcut} { +test listbox-24.4 {itemcget, itemcg shortcut} { catch {destroy .l} listbox .l .l insert end a b c d @@ -2127,20 +2125,25 @@ test listbox-27.1 {widget deletion while active} { } 0 test listbox-28.1 {listbox -activestyle} { - catch {destroy .l} + destroy .l listbox .l -activ non .l cget -activestyle } none -test listbox-28.2 {listbox -activestyle} { - catch {destroy .l} +test listbox-28.2-nonwin {listbox -activestyle} {nonwin} { + destroy .l + listbox .l + .l cget -activestyle +} dotbox +test listbox-28.2-win {listbox -activestyle} {win} { + destroy .l listbox .l .l cget -activestyle } underline test listbox-28.3 {listbox -activestyle} { - catch {destroy .l} - listbox .l -activestyle dot + destroy .l + listbox .l -activestyle und .l cget -activestyle -} dotbox +} underline test listbox-29.1 {listbox selection behavior, -state disabled} { destroy .l @@ -2160,5 +2163,5 @@ deleteWindows option clear # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/macEmbed.test b/tests/macEmbed.test deleted file mode 100644 index 81757fc..0000000 --- a/tests/macEmbed.test +++ /dev/null @@ -1,267 +0,0 @@ -# This file is a Tcl script to test out the procedures in the file -# tkMacEmbed.c. It is organized in the standard fashion for Tcl -# tests. -# -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. - -package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] -tcltest::loadTestedCommands - -test macEmbed-1.1 {TkpUseWindow procedure, bad window identifier} {macOnly} { - catch {destroy .t} - list [catch {toplevel .t -use xyz} msg] $msg -} {1 {expected integer but got "xyz"}} -test macEmbed-1.2 {TkpUseWindow procedure, bad window identifier} {macOnly} { - catch {destroy .t} - list [catch {toplevel .t -use 47} msg] $msg -} {1 {The window ID 47 does not correspond to a valid Tk Window.}} - -test macEmbed-1.3 {TkpUseWindow procedure, creating Container records} {testembed macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - frame .f2 -container 1 -width 200 -height 50 - pack .f1 .f2 - set w [winfo id .f1] - toplevel .t -use $w - list [testembed] [expr [lindex [lindex [testembed all] 1] 0] - $w] -} {{{XXX .f2 {} {}} {XXX .f1 XXX .t}} 0} -test macEmbed-1.4 {TkpUseWindow procedure, creating Container records} {testembed macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - frame .f2 -container 1 -width 200 -height 50 - pack .f1 .f2 - set w1 [winfo id .f1] - set w2 [winfo id .f2] - toplevel .t1 -use $w1 - toplevel .t2 -use $w2 - testembed -} {{XXX .f2 XXX .t2} {XXX .f1 XXX .t1}} - -# Can't think of any way to test the procedures TkpMakeWindow, -# TkpMakeContainer, or EmbedErrorProc. - -test macEmbed-2.1 {EmbeddedEventProc procedure} {testembed macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - set w1 [winfo id .f1] - toplevel .t1 -use $w1 - testembed - destroy .t1 - update - testembed -} {} -test macEmbed-2.2 {EmbeddedEventProc procedure} {testembed macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - toplevel .t1 -use [winfo id .f1] - update - destroy .f1 - testembed -} {} -test macEmbed-2.3 {EmbeddedEventProc procedure} {testembed macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - toplevel .t1 -use [winfo id .f1] - update - destroy .t1 - update - list [testembed] [winfo children .] -} {{} {}} - -test macEmbed-3.1 {EmbeddedEventProc procedure, detect creation} {testembed macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - set w1 [winfo id .f1] - set x [testembed] - toplevel .t1 -use $w1 - wm withdraw .t1 - list $x [testembed] -} {{{XXX .f1 {} {}}} {{XXX .f1 XXX .t1}}} -test macEmbed-3.2 {EmbeddedEventProc procedure, disallow position changes} \ - {macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - set w1 [winfo id .f1] - toplevel .t1 -use $w1 -bd 2 -relief raised - update - wm geometry .t1 +30+40 - update - wm geometry .t1 -} {200x200+0+0} -test macEmbed-3.3 {EmbeddedEventProc procedure, disallow position changes} \ - {macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - set w1 [winfo id .f1] - toplevel .t1 -use $w1 - update - wm geometry .t1 300x100+30+40 - update - wm geometry .t1 -} {300x100+0+0} -test macEmbed-3.4 {EmbeddedEventProc procedure, geometry requests} {macOnly} { - deleteWindows - toplevel .t1 -container 1 -width 200 -height 50 - set w1 [winfo id .t1] - toplevel .t2 -use $w1 - update - .t1 configure -width 300 -height 80 - update - list [winfo width .t1] [winfo height .t1] [wm geometry .t2] -} {300 80 300x80+0+0} -test macEmbed-3.5 {EmbeddedEventProc procedure, map requests} {macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - set w1 [winfo id .f1] - toplevel .t1 -use $w1 - set x unmapped - bind .t1 <Map> {set x mapped} - update - after 100 - update - set x -} {mapped} -test macEmbed-3.6 {EmbeddedEventProc procedure, destroy events} {macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - set w1 [winfo id .f1] - bind .f1 <Destroy> {set x dead} - set x alive - toplevel .t1 -use $w1 - update - destroy .t1 - update - list $x [winfo exists .f1] -} {dead 0} - -test macEmbed-4.1 {EmbedStructureProc procedure, configure events} {macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - set w1 [winfo id .f1] - toplevel .t1 -use $w1 - update - .t1 configure -width 180 -height 100 - update - winfo geometry .t1 -} {180x100+0+0} -test macEmbed-4.2 {EmbedStructureProc procedure, destroy events} {testembed macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - set w1 [winfo id .f1] - toplevel .t1 -use $w1 - update - set x [testembed] - destroy .f1 - list $x [testembed] -} {{{XXX .f1 XXX .t1}} {}} - -# Can't think up any tests for TkpGetOtherWindow procedure. - -test unixEmbed-5.1 {TkpClaimFocus procedure} {macOnly tempNotMac} { - catch {interp delete child} - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - frame .f2 -width 200 -height 50 - pack .f1 .f2 - interp create child - child eval "set argv {-use [winfo id .f1]}" - load {} Tk child - child eval { - . configure -bd 2 -highlightthickness 2 -relief sunken - } - focus -force .f2 - update - list [child eval { - focus . - set x [list [focus]] - update - lappend x [focus] - }] [focus] -} {{{} .} .f1} -catch {interp delete child} - -test macEmbed-6.1 {EmbedWindowDeleted procedure, check parentPtr} {testembed macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - frame .f2 -container 1 -width 200 -height 50 - frame .f3 -container 1 -width 200 -height 50 - frame .f4 -container 1 -width 200 -height 50 - pack .f1 .f2 .f3 .f4 - set x {} - lappend x [testembed] - foreach w {.f3 .f4 .f1 .f2} { - destroy $w - lappend x [testembed] - } - set x -} {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}} -test macEmbed-6.2 {EmbedWindowDeleted procedure, check embeddedPtr} {testembed macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - set w1 [winfo id .f1] - toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken - set x {} - lappend x [testembed] - destroy .t1 - update - lappend x [testembed] -} {{{XXX .f1 XXX .t1}} {}} - -test macEmbed-7.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - toplevel .t1 -use [winfo id .f1] -width 150 -height 80 - update - wm geometry .t1 +40+50 - update - wm geometry .t1 -} {150x80+0+0} -test macEmbed-7.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {macOnly} { - deleteWindows - frame .f1 -container 1 -width 200 -height 50 - pack .f1 - toplevel .t1 -use [winfo id .f1] -width 150 -height 80 - update - wm geometry .t1 70x300+10+20 - update - wm geometry .t1 -} {70x300+0+0} - - - -deleteWindows - -# cleanup -::tcltest::cleanupTests -return - - - - - - - - - - - - - diff --git a/tests/macFont.test b/tests/macFont.test deleted file mode 100644 index 88c1a96..0000000 --- a/tests/macFont.test +++ /dev/null @@ -1,284 +0,0 @@ -# This file is a Tcl script to test out the procedures in tkMacFont.c. -# It is organized in the standard fashion for Tcl tests. -# -# Some of these tests are visually oriented and cannot be checked -# programmatically (such as "does an underlined font appear to be -# underlined?"); these tests attempt to exercise the code in question, -# but there are no results that can be checked. -# -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. - -package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] -tcltest::loadTestedCommands - -catch {destroy .b} -toplevel .b -update idletasks - -set courier {Courier 12} -set cx [font measure $courier 0] - -set fixed {Monaco 12} -label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font $fixed -pack .b.l -canvas .b.c -closeenough 0 - -set t [.b.c create text 0 0 -anchor nw -just left -font $courier] -pack .b.c -update - -set ax [winfo reqwidth .b.l] -set ay [winfo reqheight .b.l] -proc getsize {} { - update - return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" -} - -testConstraint gothic 0 -set gothic {gothic 12} -set mx [font measure $gothic \u4e4e] -if {[font actual $gothic -family] != [font actual system -family]} { - testConstraint gothic 1 -} - -test macFont-1.1 {TkpFontPkgInit} {macOnly} { -} {} - -test macfont-2.1 {TkpGetNativeFont: not native} {macOnly} { - list [catch {font measure {} xyz} msg] $msg -} {1 {font "" doesn't exist}} -test macFont-2.2 {TkpGetNativeFont: native} {macOnly} { - font measure system "0" - font measure application "0" - set x {} -} {} - -test macFont-3.1 {TkpGetFontFromAttributes: no family} {macOnly} { - font actual {-underline 1} -family -} [font actual system -family] -test macFont-3.2 {TkpGetFontFromAttributes: long family name} {macOnly} { - set x "12345678901234567890123456789012345678901234567890" - set x "$x$x$x$x$x$x" - font actual "-family $x" -family -} [font actual system -family] -test macFont-3.3 {TkpGetFontFromAttributes: family} {macOnly} { - font actual {-family Courier} -family -} {Courier} -test macFont-3.4 {TkpGetFontFromAttributes: Times fonts} {macOnly} { - set x {} - lappend x [font actual {-family "Times"} -family] - lappend x [font actual {-family "Times New Roman"} -family] -} {Times Times} -test macFont-3.5 {TkpGetFontFromAttributes: Courier fonts} {macOnly} { - set x {} - lappend x [font actual {-family "Courier"} -family] - lappend x [font actual {-family "Courier New"} -family] -} {Courier Courier} -test macFont-3.6 {TkpGetFontFromAttributes: Helvetica fonts} {macOnly} { - set x {} - lappend x [font actual {-family "Geneva"} -family] - lappend x [font actual {-family "Helvetica"} -family] - lappend x [font actual {-family "Arial"} -family] -} {Geneva Helvetica Helvetica} -test macFont-3.7 {TkpGetFontFromAttributes: try aliases} {macOnly} { - font actual {arial 10} -family -} {Helvetica} -test macFont-3.8 {TkpGetFontFromAttributes: try fallbacks} {macOnly} { - font actual {{ms sans serif} 10} -family -} {Chicago} -test macFont-3.9 {TkpGetFontFromAttributes: styles} {macOnly} { - font actual {-weight normal} -weight -} {normal} -test macFont-3.10 {TkpGetFontFromAttributes: styles} {macOnly} { - font actual {-weight bold} -weight -} {bold} -test macFont-3.11 {TkpGetFontFromAttributes: styles} {macOnly} { - font actual {-slant roman} -slant -} {roman} -test macFont-3.12 {TkpGetFontFromAttributes: styles} {macOnly} { - font actual {-slant italic} -slant -} {italic} -test macFont-3.13 {TkpGetFontFromAttributes: styles} {macOnly} { - font actual {-underline false} -underline -} {0} -test macFont-3.14 {TkpGetFontFromAttributes: styles} {macOnly} { - font actual {-underline true} -underline -} {1} -test macFont-3.15 {TkpGetFontFromAttributes: styles} {macOnly} { - font actual {-overstrike false} -overstrike -} {0} -test macFont-3.16 {TkpGetFontFromAttributes: styles} {macOnly} { - font actual {-overstrike true} -overstrike -} {0} - -test macFont-4.1 {TkpDeleteFont} {macOnly} { - font actual {-family xyz} - set x {} -} {} - -test macFont-5.1 {TkpGetFontFamilies} {macOnly} { - expr {[lsearch [font families] Geneva] > 0} -} {1} - -test macFont-6.1 {TkpGetSubFonts} {testfont gothic macOnly} { - .b.l config -text "abc\u4e4e" - update - set x [testfont subfonts $fixed] -} "Monaco [font actual $gothic -family]" - -test macFont-7.1 {Tk_MeasureChars: unbounded right margin} {macOnly} { - .b.l config -wrap 0 -text "000000" - getsize -} "[expr $ax*6] $ay" -test macFont-7.2 {Tk_MeasureChars: static width buffer exceeded} {macOnly} { - .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" - getsize -} "[expr $ax*256] $ay" -test macFont-7.3 {Tk_MeasureChars: all chars did fit} {macOnly} { - .b.l config -wrap [expr $ax*10] -text "00000000" - getsize -} "[expr $ax*8] $ay" -test macFont-7.4 {Tk_MeasureChars: not all chars fit} {macOnly} { - .b.l config -wrap [expr $ax*6] -text "00000000" - getsize -} "[expr $ax*6] [expr $ay*2]" -test macFont-7.5 {Tk_MeasureChars: already saw space in line} {macOnly} { - .b.l config -wrap [expr $ax*12] -text "000000 0000000" - getsize -} "[expr $ax*7] [expr $ay*2]" -test macFont-7.6 {Tk_MeasureChars: internal spaces significant} {macOnly} { - .b.l config -wrap [expr $ax*12] -text "000 00 00000" - getsize -} "[expr $ax*7] [expr $ay*2]" -test macFont-7.7 {Tk_MeasureChars: include last partial char} {macOnly} { - .b.c dchars $t 0 end - .b.c insert $t 0 "0000" - .b.c index $t @[expr int($ax*2.5)],1 -} {2} -test macFont-7.8 {Tk_MeasureChars: at least one char on line} { macOnly} { - .b.l config -text "000000" -wrap 1 - getsize -} "$ax [expr $ay*6]" -test macFont-7.9 {Tk_MeasureChars: whole words} {macOnly} { - .b.l config -wrap [expr $ax*8] -text "000000 0000" - getsize -} "[expr $ax*6] [expr $ay*2]" -test macFont-7.10 {Tk_MeasureChars: make first part of word fit} {macOnly} { - .b.l config -wrap [expr $ax*12] -text "0000000000000000" - getsize -} "[expr $ax*12] [expr $ay*2]" -test macFont-7.11 {Tk_MeasureChars: numBytes == 0} {macOnly} { - font measure system {} -} {0} -test macFont-7.12 {Tk_MeasureChars: maxLength < 0} {macOnly} { - font measure $courier abcd -} "[expr $cx*4]" -test macFont-7.13 {Tk_MeasureChars: loop on each char} {macOnly} { - font measure $courier abcd -} "[expr $cx*4]" -test macFont-7.14 {Tk_MeasureChars: p == end} {macOnly} { - font measure $courier abcd -} "[expr $cx*4]" -test macFont-7.15 {Tk_MeasureChars: p > end} {macOnly} { - font measure $courier abc\xc2 -} "[expr $cx*4]" -test macFont-7.16 {Tk_MeasureChars: thisFamilyPtr != lastFamilyPtr} {gothic macOnly} { - font measure $courier abc\u4e4edef -} [expr $cx*6+$mx] -test macFont-7.17 {Tk_MeasureChars: measure no chars (in loop)} {gothic macOnly} { - font measure $courier \u4e4edef -} [expr $mx+$cx*3] -test macFont-7.18 {Tk_MeasureChars: final measure} {gothic macOnly} { - font measure $courier \u4e4edef -} [expr $mx+$cx*3] -test macFont-7.19 {Tk_MeasureChars: final measure (no chars)} {gothic macOnly} { - font measure $courier \u4e4e -} [expr $mx] -test macFont-7.20 {Tk_MeasureChars: maxLength >= 0} {macOnly} { - .b.l config -wrap [expr $ax*8] -text "000" - getsize -} "[expr $ax*3] $ay" -test macFont-7.21 {Tk_MeasureChars: loop on each char} {macOnly} { - .b.l config -wrap [expr $ax*8] -text "000" - getsize -} "[expr $ax*3] $ay" -test macFont-7.22 {Tk_MeasureChars: p == end} {macOnly} { - .b.l config -wrap [expr $ax*8] -text "000" - getsize -} "[expr $ax*3] $ay" -test macFont-7.23 {Tk_MeasureChars: p > end} {macOnly} { - .b.l config -wrap [expr $ax*8] -text "00\xc2" - getsize -} "[expr $ax*3] $ay" -test macFont-7.24 {Tk_MeasureChars: thisFamilyPtr != lastFamilyPtr} {gothic macOnly} { - .b.l config -wrap [expr $ax*8] -text "00\u4e4e00" - getsize -} "[expr $ax*4+$mx] $ay" -test macFont-7.25 {Tk_MeasureChars: measure no chars (in loop)} {gothic macOnly} { - .b.l config -wrap [expr $ax*8] -text "\u4e4e00" - getsize -} "[expr $mx+$ax*2] $ay" -test macFont-7.26 {Tk_MeasureChars: rest == NULL} {gothic macOnly} { - .b.l config -wrap [expr $ax*20] -text "000000\u4e4e\u4e4e00" - getsize -} "[expr $ax*8+$mx*2] $ay" -test macFont-7.27 {Tk_MeasureChars: rest != NULL in first segment} {gothic macOnly} { - .b.l config -wrap [expr $ax*5] -text "000000\u4e4e\u4e4f00" - getsize -} "[expr $ax*5] [expr $ay*3]" -test macFont-7.28 {Tk_MeasureChars: rest != NULL in next segment} {gothic macOnly} { - # even some of the "0"s would fit after \u4e4d, they should all wrap to next line. - .b.l config -wrap [expr $ax*8] -text "\u4e4d\u4e4d000000\u4e4e\u4e4f00" - getsize -} "[expr $ax*6+$mx] [expr $ay*3]" -test macFont-7.29 {Tk_MeasureChars: final measure} {gothic macOnly} { - .b.l config -wrap [expr $ax*8] -text "\u4e4e00" - getsize -} "[expr $mx+$ax*2] $ay" -test macFont-7.30 {Tk_MeasureChars: final measure (no chars)} {gothic macOnly} { - .b.l config -wrap [expr $ax*8] -text "\u4e4e" - getsize -} "$mx $ay" -test macFont-7.31 {Tk_MeasureChars: rest == NULL} {macOnly} { - .b.l config -wrap [expr $ax*1000] -text 0000 - getsize -} "[expr $ax*4] $ay" -test macFont-7.32 {Tk_MeasureChars: rest != NULL} {macOnly} { - .b.l config -wrap [expr $ax*6] -text "00000000" - getsize -} "[expr $ax*6] [expr $ay*2]" - -test macFont-8.1 {Tk_DrawChars procedure} {macOnly} { - .b.l config -text "a" - update -} {} - -test macFont-9.1 {AllocMacFont: use old font} {macOnly} { - font create xyz - button .c -font xyz - font configure xyz -family times - update - destroy .c - font delete xyz -} {} -test macFont-9.2 {AllocMacFont: extract info from style} {macOnly} { - font actual {Monaco 9 bold italic underline overstrike} -} {-family Monaco -size 9 -weight bold -slant italic -underline 1 -overstrike 0} -test macFont-9.3 {AllocMacFont: extract text metrics} {macOnly} { - font metric {Geneva 10} -fixed -} {0} -test macFont-9.4 {AllocMacFont: extract text metrics} {macOnly} { - font metric "Monaco 9" -fixed -} {1} - -destroy .b - -# cleanup -::tcltest::cleanupTests -return diff --git a/tests/macMenu.test b/tests/macMenu.test deleted file mode 100644 index 0de0f51..0000000 --- a/tests/macMenu.test +++ /dev/null @@ -1,1547 +0,0 @@ -# This file is a Tcl script to test menus in Tk. It is -# organized in the standard fashion for Tcl tests. This -# file tests the Macintosh-specific features of the menu -# system. -# -# Copyright (c) 1995-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. - -package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] -tcltest::loadTestedCommands - -test macMenu-1.0 {TkMacUseMenuID} {macOnly} { - # Can't really test TkMacUseMenuID; it's only called on startup. -} {} - -test macMenu-2.1 {GetNewID} {macOnly} { - catch {destroy .m1} - list [catch {menu .m1} msg] $msg [destroy .m1] -} {0 .m1 {}} -test macMenu-2.2 {GetNewID - cascade menu} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m2 - list [catch {menu .m2} msg] $msg [destroy .m1] [destroy .m2] -} {0 .m2 {} {}} -test macMenu-2.3 {GetNewID - running out of ids} {macOnly} { - deleteWindows - menu .menu - for {set i 0} {$i < 230} {incr i} { - menu .m$i - .menu add cascade -label ".m$i" -menu .m$i - } - menu .breaker - list [catch {.menu add cascade -menu .breaker} msg] $msg [deleteWindows] -} {1 {No more menus can be allocated.} {}} - -test macMenu-3.1 {FreeID} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} - -# No way to test running out of ids in TkpNewPlatformMenu -test macMenu-4.1 {TkpNewMenu} {macOnly} { - catch {destroy .m1} - list [catch {menu .m1} msg] $msg [catch {destroy .m1} msg2] $msg2 -} {0 .m1 0 {}} -test macMenu-4.2 {TkpNewMenu - checking for help menu when one is there} {macOnly} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - menu .m1.help -tearoff 0 - .m1.help add command -label Test - . configure -menu .m1 - raise . - update - list [catch {menu .m2} msg] $msg [destroy .m1] [destroy .m2] [. configure -menu ""] -} {0 .m2 {} {} {}} -test macMenu-4.3 {TkpNewMenu - menubar set but different interp} {macOnly} { - catch {interp delete testinterp} - catch {destroy .m1} - interp create testinterp - load {} Tk testinterp - interp eval testinterp {raise .} - interp eval testinterp {menu .m1} - interp eval testinterp {. configure -menu .m1} - interp eval testinterp {update} - list [catch {menu .m1} msg] $msg [destroy .m1] [interp delete testinterp] -} {0 .m1 {} {}} -test macMenu-4.4 {TkpNewMenu - menubar set but new menu has different parent} {macOnly} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 -tearoff 0 - .m1 add cascade -menu .m1.help - menu .m2 - .m2 add cascade -menu .m2.help - . configure -menu .m1 - raise . - update - list [catch {menu .m2.help} msg] $msg [. configure -menu ""] [destroy .m1] [destroy .m2] -} {0 .m2.help {} {} {}} -test macMenu-4.5 {TkpNewMenu - menubar set, same parent, not .help} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add cascade -menu .m1.help - . configure -menu .m1 - raise . - update - list [catch {menu .m1.foo} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 .m1.foo {} {}} -test macMenu-4.6 {TkpNewMenu - creating the help menu} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add cascade -menu .m1.help - . configure -menu .m1 - raise . - update - list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 .m1.help {} {}} - -test macMenu-5.1 {TkpDestroyMenu} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test macMenu-5.2 {TkpDestroyMenu - help menu} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add cascade -menu .m1.help - . configure -menu .m1 - menu .m1.help - raise . - update - list [catch {destroy .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-5.3 {TkpDestroyMenu - idle handler pending} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label test - list [catch {destroy .m1} msg] $msg -} {0 {}} -test macMenu-5.4 {TkpDestroyMenu - idle handler not pending} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label test - update idletasks - list [catch {destroy .m1} msg] $msg -} {0 {}} - -test macMenu-6.1 {SetMenuCascade} {macOnly} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - menu .m2 - list [catch {.m2 add cascade -menu .m1} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test macMenu-6.2 {SetMenuCascade - running out of ids} {macOnly} { - deleteWindows - menu .menu - for {set i 0} {$i < 230} {incr i} { - menu .m$i - .menu add cascade -label ".m$i" -menu .m$i - } - menu .breaker - list [catch {.menu add cascade -menu .breaker} msg] $msg [deleteWindows] -} {1 {No more menus can be allocated.} {}} - -test macMenu-7.1 {TkpDestroyMenuEntry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "test" - list [catch {.m1 delete 1} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-7.2 {TkpDestroyMenuEntry - help menu} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.help - menu .m1.help -tearoff 0 - .m1.help add command -label "test" - . configure -menu .m1 - raise . - update - list [catch {.m1.help delete test} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} - -test macMenu-8.1 {GetEntryText} {macOnly} { - catch {destroy .m1} - list [catch {menu .m1} msg] $msg [destroy .m1] -} {0 .m1 {}} -test macMenu-8.2 {GetEntryText} {macOnly testImageType} { - catch {destroy .m1} - catch {image delete image1} - menu .m1 - image create test image1 - list [catch {.m1 add command -image image1} msg] $msg [destroy .m1] [image delete image1] -} {0 {} {} {}} -test macMenu-8.3 {GetEntryText} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -bitmap questhead} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-8.4 {GetEntryText} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-8.5 {GetEntryText} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "foo" - list [catch {.m1 add command -label "foo"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-8.6 {GetEntryText} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -label "This is a very long string. 9012345678900123456789001234567890012345678900123456789001234567890012345678900123456789001234567890012345678900123456789001234567890012345678900123456789001234567890012345678900123456789001234567890012345678900123456789001234567890"} \ - msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-8.7 {GetEntryText - elipses character} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -label "foo..."} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-8.8 {GetEntryText - false elipses character} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -label "foo."} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-8.9 {GetEntryText - false elipses character} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -label "foo.."} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-8.10 {GetEntryText - false elipses character} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -label "foo.b"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-8.11 {GetEntryText - false elipses character} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -label "foo..b"} msg] $msg [destroy .m1] -} {0 {} {}} - - -# test macMenu-9.1 - assumes some fonts -test macMenu-9.1 {FindMarkCharacter} {macOnly} { - catch {destroy .m1} - menu .m1 -font "Helvetica 12" -tearoff 0 - .m1 add checkbutton -label test - .m1 invoke test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -# All standard fonts have "¥" defined. We can't test further. - -test macMenu-10.1 {SetMenuIndicator - cascade entry} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add cascade -label foo} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-10.2 {SetMenuIndicator - not radio or checkbutton} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -label foo} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-10.3 {SetMenuIndicator - indiatorOn false} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add checkbutton -label foo -indicatoron 0} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-10.4 {SetMenuIndicator - entry not selected} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add checkbutton -label foo} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-10.5 {SetMenuIndicator - checkbutton} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label foo - list [catch {.m1 invoke foo} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-10.6 {SetMenuIndicator - radio button} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add radiobutton -label foo - list [catch {.m1 invoke foo} msg] $msg [destroy .m1] -} {0 {} {}} - -test macMenu-11.1 {SetMenuTitle} {macOnly} { - catch {destroy .m1} - catch {destroy .container} - menu .container - menu .m1 -#previous title is .m1 - .container add cascade -label "File" -menu .m1 - list [catch {. configure -menu .container} msg] $msg [. configure -menu ""] [destroy .container .m1] -} {0 {} {} {}} -test macMenu-11.2 {SetMenuTitle} {macOnly} { - menu .container - menu .m1 - . configure -menu "" -#previous title is .m1 - .container add cascade -label "F" -menu .m1 - list [catch {. configure -menu .container} msg] $msg [. configure -menu ""] [destroy .container .m1] -} {0 {} {} {}} - -test macMenu-12.1 {TkpConfigureMenuEntry} {macOnly} { - catch {destroy .m1} - . configure -menu "" - menu .m1 - .m1 add cascade -menu .m3 - list [catch {.m1 entryconfigure 1 -menu .m2} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.2 {TkpConfigureMenuEntry} {macOnly} { - catch {destroy .m1} - catch {destroy .m2} - . configure -menu "" - menu .m1 - .m1 add cascade -menu .m3 - menu .m2 - list [catch {.m1 entryconfigure 1 -menu .m2} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test macMenu-12.3 {TkpConfigureMenuEntry - running out of ids} {macOnly} { - deleteWindows - menu .menu - for {set i 0} {$i < 230} {incr i} { - menu .m$i - .menu add cascade -label ".m$i" -menu .m$i - } - menu .breaker - list [catch {.menu add cascade -menu .breaker} msg] $msg [deleteWindows] -} {1 {No more menus can be allocated.} {}} -test macMenu-12.4 {TkpConfigureMenuEntry - Control} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Control+S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.5 {TkpConfigureMenuEntry - Ctrl} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Ctrl+S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.6 {TkpConfigureMenuEntry - Shift} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Shift+S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.7 {TkpConfigureMenuEntry - Option} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Opt+S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.8 {TkpConfigureMenuEntry - Command} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Command+S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.9 {TkpConfigureMenuEntry - Cmd} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Cmd+S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.10 {TkpConfigureMenuEntry - Alt} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Alt+S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.11 {TkpConfigureMenuEntry - Meta} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Meta+S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.12 {TkpConfigureMenuEntry - Two modifiers} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Cmd+Shift+S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.13 {TkpConfigureMenuEntry - dash instead of plus} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -accel "Command-S"} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.14 {TkpConfigureMenuEntry - idler pending} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label test - list [catch {.m1 entryconfigure test -label test2} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-12.15 {TkpConfigureMenuEntry - idler not pending} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label test - update idletasks - list [catch {.m1 entryconfigure test -label test2} msg] $msg [destroy .m1] -} {0 {} {}} - -test macMenu-13.1 {ReconfigureIndividualMenu - getting rid of zero items} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.2 {ReconfigureIndividualMenu - getting rid of one item} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label test - update idletasks - .m1 delete test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.3 {ReconfigureIndividualMenu - getting rid of more than one} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label test - .m1 add command -label test2 - update idletasks - .m1 entryconfigure test2 -label "test two" - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.4 {ReconfigureIndividualMenu - separator} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add separator - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.5 {ReconfigureIndividualMenu - disabled} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command - .m1 entryconfigure 1 -state disabled - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.6 {ReconfigureIndividualMenu - active} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command - .m1 entryconfigure 1 -state active - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.7 {ReconfigureIndividualMenu - checkbutton not checked} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.8 {ReconfigureIndividualMenu - checkbutton - indicator off} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label test -indicatoron 0 - .m1 invoke test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.9 {ReconfigureIndividualMenu - checkbutton on} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label test - .m1 invoke test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.10 {ReconfigureIndividualMenu - radiobutton not checked} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add radiobutton -label test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.11 {ReconfigureIndividualMenu - radiobutton - indicator off} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add radiobutton -label test -indicatoron 0 - .m1 invoke test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.12 {ReconfigureIndividualMenu - radiobutton on} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add radiobutton -label test - .m1 invoke test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.13 {ReconfigureIndividualMenu} {macOnly} { - catch {destroy .m1} - . configure -menu "" - menu .m1 - .m1 add cascade -menu .m3 - .m1 entryconfigure 1 -menu .m2 - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.14 {ReconfigureIndividualMenu} {macOnly} { - catch {destroy .m1} - catch {destroy .m2} - . configure -menu "" - menu .m1 - .m1 add cascade -menu .m3 - menu .m2 - .m1 entryconfigure 1 -menu .m2 - list [catch {update idletasks} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test macMenu-13.15 {ReconfigureIndividualMenu - accelerator} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -accel "Command-S" - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.16 {ReconfigureIndividualMenu - parent is disabled} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -label .m1.edit -label "Edit" -state disabled - menu .m1.edit - .m1.edit add command -label foo - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-13.17 {ReconfigureIndividualMenu - disabling parent} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -label .m1.edit -label Edit - menu .m1.edit - .m1.edit add command -label foo - .m1 entryconfigure Edit -state disabled - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} - -test macMenu-14.1 {ReconfigureMacintoshMenu - normal menu} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label test - list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-14.2 {ReconfigureMacintoshMenu - apple menu} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.apple - menu .m1.apple -tearoff 0 - .m1.apple add command -label test - . configure -menu .m1 - raise . - list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-14.3 {ReconfigureMacintoshMenu - help menu} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.help - menu .m1.help -tearoff 0 - .m1.help add command -label test - . configure -menu .m1 - raise . - list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-14.4 {ReconfigureMacintoshMenu - menubar} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.file -label "foo" - menu .m1.file - . configure -menu .m1 - raise . - .m1 entryconfigure foo -label "File" - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} - -test macMenu-15.1 {CompleteIdlers - no idle pending} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label test - update idletasks - list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-15.2 {CompleteIdlers - idle pending} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label test - list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-15.3 {CompleteIdlers - recursive} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.m2 -label test - menu .m1.m2 - .m1.m2 add command -label test - list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {0 {} {}} - -#Don't know how to generate nested post menus -test macMenu-16.1 {TkpPostMenu} {macOnly} { - catch {destroy .m1} - menu .m1 -postcommand "destroy .m1" - list [catch {.m1 post 40 40} msg] $msg -} {0 {}} -test macMenu-16.2 {TkpPostMenu} {macOnly} { - catch {destroy .m1} - menu .m1 -postcommand "blork" - list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {1 {invalid command name "blork"} {}} -# We need to write the interactive test for menu posting. - -test macMenu-17.1 {TkpMenuNewEntry - no idle pending} {macOnly} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command -label test} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-17.2 {TkpMenuNewEntry - idle pending} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label test - list [catch {.m1 add command -label test2} msg] $msg [destroy .m1] -} {0 {} {}} - -test macMenu-18.1 {DrawMenuBarWhenIdle} {macOnly} { - catch {destroy .m1} - . configure -menu "" - menu .m1 - . configure -menu .m1 - list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.2 {DrawMenuBarWhenIdle - clearing old apple menu out} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.apple - menu .m1.apple - .m1.apple add command -label test - . configure -menu .m1 - raise . - update - . configure -menu "" - raise . - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-18.3 {DrawMenuBarWhenIdle - clearing out old help menu} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.help - menu .m1.help - .m1.help add command -label test - . configure -menu .m1 - raise . - update - . configure -menu "" - raise . - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-18.4 {DrawMenuBarWhenIdle - menu not there} {macOnly} { - catch {destroy .m1} - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] -} {0 {} {}} -test macMenu-18.5 {DrawMenuBarWhenIdle - menu there} {macOnly} { - catch {destroy .m1} - menu .m1 - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.6 {DrawMenuBarWhenIdle - no apple menu} {macOnly} { - catch {destroy .m1} - menu .m1 - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.7 {DrawMenuBarWhenIdle - apple menu references but not there} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.apple - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.8 {DrawMenuBarWhenIdle - apple menu there} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.apple - menu .m1.apple - .m1.apple add command -label test - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.9 {DrawMenuBarWhenIdle - apple menu there; no idle handler} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.apple - menu .m1.apple - .m1.apple add command -label test - . configure -menu .m1 - raise . - update idletasks - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.10 {DrawMenuBarWhenIdle - no help menu} {macOnly} { - catch {destroy .m1} - menu .m1 - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.11 {DrawMenuBarWhenIdle - help menu referenced but not there} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.help - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.12 {DrawMenuBarWhenIdle - help menu there} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.help - menu .m1.help - .m1.help add command -label test - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.13 {DrawMenuBarWhenIdle - help menu there - no idlers} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.help - menu .m1.help - .m1.help add command -label test - . configure -menu .m1 - raise . - update idletasks - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -# Can't generate no menubar clone -test macMenu-18.14 {DrawMenuBarWhenIdle - apple and help menus in tearoff menubar} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -menu .m1.apple - .m1 add cascade -menu .m1.help - menu .m1.apple - menu .m1.help - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.15 {DrawMenuBarWhenIdle - apple and help menus in non-tearoff menubar} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add cascade -menu .m1.apple - .m1 add cascade -menu .m1.help - menu .m1.apple - menu .m1.help - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.16 {DrawMenuBarWhenIdle - no apple menu} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.17 {DrawMenuBarWhenIdle - apple menu} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - . configure -menu .m1 - .m1 add cascade -menu .m1.apple - menu .m1.apple - .m1.apple add cascade -label test -menu .m1.apple.test - menu .m1.apple.test - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.18 {DrawMenuBarWhenIdle - big for loop} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - menu .m1.apple -tearoff 0 - menu .m1.help -tearoff 0 - menu .m1.foo -tearoff 0 - .m1 add cascade -menu .m1.apple - .m1 add cascade -menu .m1.help - .m1 add cascade -label Foo -menu .m1.foo - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-18.19 {DrawMenuBarWhenIdle = disabled menu} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - menu .m1.edit -tearoff 0 - .m1 add cascade -menu .m1.edit -label Edit - . configure -menu .m1 - raise . - .m1 entryconfigure Edit -state disabled - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} - -test macMenu-19.1 {RecursivelyInsertMenu} {macOnly} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .main} - catch {destroy .t2} - toplevel .t2 -menu .main - wm geometry .t2 +0+0 - menu .main - .main add cascade -menu .m1 -label ".m1" - menu .m1 - .m1 add command -label "Test 2" - .m1 add cascade -label ".m2" -menu .m2 - menu .m2 - .m2 add command -label "Test 3" - list [catch {raise .t2} msg] $msg [destroy .t2 .main .m1 .m2] -} {0 {} {}} -test macMenu-19.2 {RecursivelyInsertMenu} {macOnly} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .main} - catch {destroy .t2} - toplevel .t2 -menu .main - wm geometry .t2 +0+0 - menu .main - .main add cascade -menu .m1 -label ".m1" - menu .m1 - .m1 add command -label "Test 2" - .m1 add cascade -label ".m2" -menu .m2 - menu .m2 - .m2 add command -label "Test 3" - list [catch {raise .t2} msg] $msg [destroy .t2 .main .m1 .m2] -} {0 {} {}} - -test macMenu-20.1 {SetDefaultMenuBar} {macOnly} { - . configure -menu "" - raise . - list [catch {update} msg] $msg -} {0 {}} - -test macMenu-21.1 {TkpSetMainMenubar - not front window} {macOnly} { - catch {destroy .m1} - catch {destroy .t2} - toplevel .t2 - wm geometry .t2 +50+50 - menu .m1 - raise . - update - list [catch {.t2 configure -menu .m1} msg] $msg [destroy .t2] [destroy .m1] -} {0 {} {} {}} -test macMenu-21.2 {TkpSetMainMenubar - menu null} {macOnly} { - . configure -menu "" - raise . - list [catch {update} msg] $msg -} {0 {}} -test macMenu-21.3 {TkpSetMainMenubar - different interps} {macOnly} { - catch {destroy .m1} - catch {interp delete testinterp} - interp create testinterp - load {} Tk testinterp - menu .m1 - . configure -menu .m1 - raise . - update - interp eval testinterp {menu .m1} - interp eval testinterp {. configure -menu .m1} - interp eval testinterp {raise .} - list [catch {interp eval testinterp {update}} msg] $msg [interp delete testinterp] [. configure -menu ""] [destroy .m1] -} {0 {} {} {} {}} -test macMenu-21.4 {TkpSetMainMenubar - different windows} {macOnly} { - catch {destroy .m1} - catch {destroy .t2} - menu .m1 - . configure -menu .m1 - toplevel .t2 - wm geometry .t2 +50+50 - .t2 configure -menu .m1 - raise . - update - raise .t2 - list [catch {update} msg] $msg [destroy .t2] [. configure -menu ""] [destroy .m1] -} {0 {} {} {} {}} -test macMenu-21.5 {TkpSetMainMenubar - old menu was null} {macOnly} { - catch {destroy .m1} - . configure -menu "" - update - menu .m1 - . configure -menu .m1 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test macMenu-21.6 {TkpSetMainMenubar - old menu different} {macOnly} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - menu .m2 - . configure -menu .m1 - raise . - update - . configure -menu .m2 - raise . - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] [destroy .m2] -} {0 {} {} {} {}} -test macMenu-21.7 {TkpSetMainMenubar - child window NULL - parent window now} {macOnly} { - catch {destroy .m1} - catch {destroy .t2} - toplevel .t2 - menu .m1 - .m1 add cascade -label Foo -menu .m1.foo - menu .m1.foo - .m1.foo add command -label foo - . configure -menu .m1 - raise .t2 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] [destroy .t2] -} {0 {} {} {} {}} -test macMenu-21.8 {TkpSetMainMenubar - tearoff window} {macOnly} { - catch {destroy .t2} - toplevel .t2 -menu .t2.m1 - menu .t2.m1 - .t2.m1 add cascade -label File -menu .t2.m1.foo - menu .t2.m1.foo - .t2.m1.foo add command -label foo - raise .t2 - tk::TearOffMenu .t2.m1.foo 100 100 - list [catch {update} msg] $msg [destroy .t2] -} {0 {} {}} - -test macMenu-22.1 {TkSetWindowMenuBar} {macOnly} { -} {} - -test macMenu-23.1 {TkMacDispatchMenuEvent} {macOnly} { - # needs to be interactive. -} {} - -test macMenu-24.1 {GetMenuIndicatorGeometry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label foo - .m1 invoke foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} - -test macMenu-25.1 {GetMenuAccelGeometry - cascade entry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -label foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test macMenu-25.2 {GetMenuAccelGeometry - no accel} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test macMenu-25.3 {GetMenuAccelGeometry - no special chars - arbitrary string} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -accel "Test" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test macMenu-25.4 {GetMenuAccelGeometry - Command} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Cmd+S" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test macMenu-25.5 {GetMenuAccelGeometry - Control} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Ctrl+S" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test macMenu-25.6 {GetMenuAccelGeometry - Shift} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Shift+S" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test macMenu-25.7 {GetMenuAccelGeometry - Option} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Opt+S" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test macMenu-25.8 {GetMenuAccelGeometry - Combination} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Cmd+Shift+S" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test macMenu-25.9 {GetMenuAccelGeometry - extra text} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Command+Delete" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} - -test macMenu-26.1 {GetTearoffEntryGeometry} {macOnly} { - # can't call this on power mac. -} {} - -test macMenu-27.1 {GetMenuSeparatorGeometry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add separator - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} - -test macMenu-28.1 {DrawMenuEntryIndicator - non-checkbutton} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-28.2 {DrawMenuEntryIndicator - indicator off} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label foo -indicatoron 0 - .m1 invoke foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-28.3 {DrawMenuEntryIndicator - not selected} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-28.4 {DrawMenuEntryIndicator - checkbutton} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label foo - .m1 invoke foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-28.5 {DrawMenuEntryIndicator - radiobutton} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add radiobutton -label foo - .m1 invoke foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} - -# Cannot reproduce resources missing or color allocation failing easily. -test macMenu-29.1 {DrawSICN} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Cmd+S" - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} - -# Cannot reproduce resources missing -test macMenu-30.1 {DrawMenuEntryAccelerator - cascade entry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-30.2 {DrawMenuEntryAccelerator - no accel string} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-30.3 {DrawMenuEntryAccelerator - random accel string} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-30.4 {DrawMenuEntryAccelerator - Command} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Cmd+S" - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-30.5 {DrawMenuEntryAccelerator - Option} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Opt+S" - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-30.6 {DrawMenuEntryAccelerator - Shift} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Shift+S" - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-30.7 {DrawMenuEntryAccelerator - Control} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Ctrl+S" - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test macMenu-30.8 {DrawMenuEntryAccelerator - combination} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -accel "Cmd+Shift+S" - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} - -test macMenu-31.1 {DrawMenuSeparator} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add separator - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} - -test macMenu-32.1 {TkpDrawMenuEntryLabel} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} - -test macMenu-33.1 {MenuDefProc - No way to test automatically.} {} {} -test macMenu-34.1 {TkMacHandleTearoffMenu - no way to test automatically} {} {} -test macMenu-35.1 {TkpInitializeMenuBindings - nothing to do} {} {} - -test macMenu-36.1 {TkpComputeMenubarGeometry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -label foo - . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} - -test macMenu-37.1 {DrawTearoffEntry - can't do automatically} {} {} -test macMenu-38.1 {TkMacSetHelpMenuItemCount - called at boot time} {} {} -test macMenu-39.1 {TkMacMenuClick - can't do automatically} {} {} - -test macMenu-40.1 {TkpDrawMenuEntry - gc for active and not strict motif} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - .m1 entryconfigure 1 -state active - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -activeforeground red - set tearoff [tk::TearOffMenu .m1 40 40] - .m1 entryconfigure 1 -state active - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.3 {TkpDrawMenuEntry - gc for active and strict motif} {macOnly} { - catch {destroy .m1} - menu .m1 - set tk_strictMotif 1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - .m1 entryconfigure 1 -state active - list [update] [destroy .m1] [set tk_strictMotif 0] -} {{} {} 0} -test macMenu-40.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} {macOnly} { - catch {destroy .m1} - menu .m1 -disabledforeground blue - .m1 add command -label foo -state disabled -background red - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} {macOnly} { - catch {destroy .m1} - menu .m1 -disabledforeground blue - .m1 add command -label foo -state disabled - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} {macOnly} { - catch {destroy .m1} - menu .m1 -disabledforeground "" - .m1 add command -label foo -state disabled - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.7 {TkpDrawMenuEntry - gc for normal - custom entry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -foreground red - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.8 {TkpDrawMenuEntry - gc for normal} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.9 {TkpDrawMenuEntry - gc for indicator - custom entry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label foo -selectcolor orange - .m1 invoke 1 - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.10 {TkpDrawMenuEntry - gc for indicator} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label foo - .m1 invoke 1 - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.11 {TkpDrawMenuEntry - border - custom entry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -activebackground green - set tearoff [tk::TearOffMenu .m1 40 40] - .m1 entryconfigure 1 -state active - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.12 {TkpDrawMenuEntry - border} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - .m1 entryconfigure 1 -state active - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.13 {TkpDrawMenuEntry - active border - strict motif} {macOnly} { - catch {destroy .m1} - set tk_strictMotif 1 - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - .m1 entryconfigure 1 -state active - list [update] [destroy .m1] [set tk_strictMotif 0] -} {{} {} 0} -test macMenu-40.14 {TkpDrawMenuEntry - active border - custom entry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -activeforeground yellow - set tearoff [tk::TearOffMenu .m1 40 40] - .m1 entryconfigure 1 -state active - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.15 {TkpDrawMenuEntry - active border} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - .m1 entryconfigure 1 -state active - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.16 {TkpDrawMenuEntry - font - custom entry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo -font "Helvectica 72" - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.17 {TkpDrawMenuEntry - font} {macOnly} { - catch {destroy .m1} - menu .m1 -font "Courier 72" - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.18 {TkpDrawMenuEntry - separator} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add separator - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.19 {TkpDrawMenuEntry - standard} {macOnly} { - catch {destroy .mb} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.20 {TkpDrawMenuEntry - disabled cascade item} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add cascade -label File -menu .m1.file - menu .m1.file - .m1.file add command -label foo - .m1 entryconfigure File -state disabled - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.21 {TkpDrawMenuEntry - indicator} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label macMenu-40.20 - .m1 invoke 0 - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-40.22 {TkpDrawMenuEntry - indicator - hideMargin} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label macMenu-40.21 -hidemargin 1 - .m1 invoke 0 - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} - -test macMenu-41.1 {TkpComputeStandardMenuGeometry - no entries} {macOnly} { - catch {destroy .m1} - menu .m1 - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.2 {TkpComputeStandardMenuGeometry - one entry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "one" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.3 {TkpComputeStandardMenuGeometry - more than one entry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "one" - .m1 add command -label "two" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.4 {TkpComputeStandardMenuGeometry - separator} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add separator - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.5 {TkpComputeStandardMenuGeometry - standard label geometry} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "test" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.6 {TkpComputeStandardMenuGeometry - different font for entry} {macOnly} { - catch {destroy .m1} - menu .m1 -font "Helvetica 12" - .m1 add command -label "test" -font "Courier 12" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.7 {TkpComputeStandardMenuGeometry - second entry larger} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "test" - .m1 add command -label "test test" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.8 {TkpComputeStandardMenuGeometry - first entry larger} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "test test" - .m1 add command -label "test" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.9 {TkpComputeStandardMenuGeometry - accelerator} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "test" -accel "Ctrl+S" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.10 {TkpComputeStandardMenuGeometry - second accel larger} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "test" -accel "1" - .m1 add command -label "test" -accel "1 1" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.11 {TkpComputeStandardMenuGeometry - second accel smaller} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "test" -accel "1 1" - .m1 add command -label "test" -accel "1" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.12 {TkpComputeStandardMenuGeometry - indicator} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label test - .m1 invoke 1 - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.13 {TkpComputeStandardMenuGeometry - second indicator less or equal } {macOnly testImageType} { - catch {destroy .m1} - catch {image delete image1} - image create test image1 - menu .m1 - .m1 add checkbutton -image image1 - .m1 invoke 1 - .m1 add checkbutton -label test - .m1 invoke 2 - list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test macMenu-41.14 {TkpComputeStandardMenuGeometry - hidden margin} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label macMenu-41.15 -hidemargin 1 - .m1 invoke macMenu-41.15 - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.15 {TkpComputeStandardMenuGeometry - zero sized menus} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.16 {TkpComputeStandardMenuGeometry - first column bigger} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label one - .m1 add command -label two - .m1 add command -label three -columnbreak 1 - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.17 {TkpComputeStandardMenuGeometry - second column bigger} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label one - .m1 add command -label two -columnbreak 1 - .m1 add command -label three - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.18 {TkpComputeStandardMenuGeometry - three columns} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label one - .m1 add command -label two -columnbreak 1 - .m1 add command -label three - .m1 add command -label four - .m1 add command -label five -columnbreak 1 - .m1 add command -label six - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.19 {TkpComputeStandardMenuGeometry - entry without accel long} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label "This is a long item with no accel." - .m1 add command -label foo -accel "Cmd+S" - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-41.20 {TkpComputeStandardMenuGeometry - entry with accel long} {macOnly} { - catch {destroy .m1} - menu .m1 -tearoff 0 - .m1 add command -label foo - .m1 add command -label "This is a long label with an accel." -accel "Cmd+W" - list [update idletasks] [destroy .m1] -} {{} {}} - -test macMenu-42.1 {DrawMenuEntryLabel - setting indicatorSpace} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "foo" - set tearoff [tk::TearOffMenu .m1] - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-42.2 {DrawMenuEntryLabel - drawing image} {macOnly testImageType} { - catch {destroy .m1} - catch {image delete image1} - image create test image1 - menu .m1 - .m1 add command -image image1 - set tearoff [tk::TearOffMenu .m1] - list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test macMenu-42.3 {DrawMenuEntryLabel - drawing select image} {macOnly testImageType} { - catch {destroy .m1} - catch {eval image delete [image names]} - image create test image1 - image create test image2 - menu .m1 - .m1 add checkbutton -image image1 -selectimage image2 - .m1 invoke 1 - set tearoff [tk::TearOffMenu .m1] - list [update idletasks] [destroy .m1] [eval image delete [image names]] -} {{} {} {}} -test macMenu-42.4 {DrawMenuEntryLabel - drawing a bitmap} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -bitmap questhead - set tearoff [tk::TearOffMenu .m1] - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-42.5 {DrawMenuEntryLabel - drawing null label} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command - set tearoff [tk::TearOffMenu .m1] - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-42.6 {DrawMenuEntryLabel - drawing real label} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "This is a long label" -underline 3 - set tearoff [tk::TearOffMenu .m1] - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-42.7 {DrawMenuEntryLabel - drawing disabled label} {macOnly} { - catch {destroy .m1} - menu .m1 -disabledforeground "" - .m1 add command -label "This is a long label" -state disabled - set tearoff [tk::TearOffMenu .m1] - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-42.8 {DrawMenuEntryLabel - disabled images} {macOnly testImageType} { - catch {destroy .m1} - catch {image delete image1} - image create test image1 - menu .m1 - .m1 add command -image image1 -state disabled - set tearoff [tk::TearOffMenu .m1 100 100] - list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} - -test macMenu-43.1 {GetMenuLabelGeometry - image} {macOnly testImageType} { - catch {destroy .m1} - catch {image delete image1} - menu .m1 - image create test image1 - .m1 add command -image image1 - list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test macMenu-43.2 {GetMenuLabelGeometry - bitmap} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -bitmap questhead - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-43.3 {GetMenuLabelGeometry - no text} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command - list [update idletasks] [destroy .m1] -} {{} {}} -test macMenu-43.4 {GetMenuLabelGeometry - text} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label "This is a test." - list [update idletasks] [destroy .m1] -} {{} {}} - -test macMenu-44.1 {DrawMenuEntryBackground} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test macMenu-44.2 {DrawMenuEntryBackground} {macOnly} { - catch {destroy .m1} - menu .m1 - .m1 add command -label foo - set tearoff [tk::TearOffMenu .m1 40 40] - $tearoff activate 0 - list [update] [destroy .m1] -} {{} {}} - -test macMenu-45.1 {TkpMenuInit - called at boot time} {macOnly} { -} {} - -# cleanup -deleteWindows -::tcltest::cleanupTests -return diff --git a/tests/macWinMenu.test b/tests/macWinMenu.test deleted file mode 100644 index 42ecd90..0000000 --- a/tests/macWinMenu.test +++ /dev/null @@ -1,103 +0,0 @@ -# This file is a Tcl script to test menus in Tk. It is -# organized in the standard fashion for Tcl tests. It tests -# the common implementation of Macintosh and Windows menus. -# -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. - -package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] -tcltest::loadTestedCommands - -test macWinMenu-1.1 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { - catch {destroy .m1} - menu .m1 -postcommand "destroy .m1" - .m1 add command -label "macWinMenu-1.1: Hit Escape" - list [catch {.m1 post 40 40} msg] $msg -} {0 {}} -test macWinMenu-1.2 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { - catch {destroy .m1} - catch {destroy .m2} - set foo1 foo - set foo2 foo - menu .m1 -postcommand "set foo1 .m1" - .m1 add cascade -menu .m2 -label "macWinMenu-1.2: Hit Escape" - menu .m2 -postcommand "set foo2 .m2" - update idletasks - list [catch {.m1 post 40 40} msg] $msg [set foo1] [set foo2] \ - [destroy .m1 .m2] [catch {unset foo1}] [catch {unset foo2}] -} {0 .m2 .m1 .m2 {} 0 0} - -test macWinMenu-1.3 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { - catch {destroy .l1} - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} - label .l1 -text "Preparing menus..." - pack .l1 - update idletasks - menu .m1 -postcommand ".l1 configure -text \"Destroying .m1...\"; update idletasks; destroy .m1" - menu .m2 -postcommand ".l1 configure -text \"Destroying .m2...\"; update idletasks; destroy .m2" - menu .m3 -postcommand ".l1 configure -text \"Destroying .m3...\"; update idletasks; destroy .m3" - .m1 add cascade -menu .m2 -label "macWinMenu-1.3: Hit Escape (.m2)" - .m1 add cascade -menu .m3 -label ".m3" - update idletasks - list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3] -} {0 {} {}} -test macWinMenu-1.4 {PreprocessMenu} {macOrPc} { - catch {destroy .l1} - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} - catch {destroy .m4} - label .l1 -text "Preparing menus..." - pack .l1 - update idletasks - menu .m1 -postcommand ".l1 configure -text \"Destroying .m1...\"; update idletasks; destroy .m1" - .m1 add cascade -menu .m2 -label "macWinMenu-1.4: Hit Escape (.m2)" - .m1 add cascade -menu .m3 -label ".m3" - menu .m2 -postcommand ".l1 configure -text \"Destroying .m2...\"; update idletasks; destroy .m2" - .m2 add cascade -menu .m4 -label ".m4" - menu .m3 -postcommand ".l1 configure -text \"Destroying .m3...\"; update idletasks; destroy .m3" - menu .m4 -postcommand ".l1 configure -text \"Destroying .m4...\"; update idletasks; destroy .m4" - update idletasks - list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3 .m4] -} {0 {} {}} -test macWinMenu-1.5 {PreprocessMenu} {macOrPc} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - .m1 add cascade -menu .m2 -label "You may need to hit Escape to get this menu to go away." - menu .m2 -postcommand glorp - list [catch {.m1 post 40 40} msg] $msg [destroy .m1 .m2] -} {1 {invalid command name "glorp"} {}} - -test macWinMenu-2.1 {TkPreprocessMenu} {macOrPc nonUnixUserInteraction} { - catch {destroy .m1} - set foo test - menu .m1 -postcommand "set foo 2.1" - .m1 add command -label "macWinMenu-2.1: Hit Escape" - list [catch {.m1 post 40 40} msg] $msg [set foo] [destroy .m1] [unset foo] -} {0 2.1 2.1 {} {}} - -# cleanup -deleteWindows -::tcltest::cleanupTests -return - - - - - - - - - - - - - diff --git a/tests/macscrollbar.test b/tests/macscrollbar.test deleted file mode 100644 index c8cc214..0000000 --- a/tests/macscrollbar.test +++ /dev/null @@ -1,93 +0,0 @@ -# This file is a Tcl script to test out scrollbar widgets and -# the "scrollbar" command of Tk. This file only tests Macintosh -# specific features. It is organized in the standard fashion for -# Tcl tests. -# -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. - -package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] -tcltest::loadTestedCommands - -update - -# Tests for display and layout -wm geometry . 50x300 -scrollbar .s -pack .s -fill y -expand 1 -update -test macscroll-1.1 {TkpDisplayScrollbar procedure} {macOnly} { - list [.s configure -width] [.s configure -bd] -} {{-width width Width 16 16} {-borderwidth borderWidth BorderWidth 0 0}} -test macscroll-1.2 {TkpDisplayScrollbar procedure} {macOnly} { - # Exercise drawing 3D relief - pack .s -fill y -expand 1 -anchor center - .s configure -bd 4 - update - focus .s - update -} {} -test macscroll-1.3 {TkpDisplayScrollbar procedure} {macOnly} { - pack .s -fill y -expand 1 -anchor e - update - set x [.s configure -width] - pack .s -fill y -expand 1 -anchor w - update - list [.s configure -width] $x -} {{-width width Width 16 16} {-width width Width 16 16}} -test macscroll-1.4 {TkpDisplayScrollbar procedure} {macOnly} { - wm geometry . 300x50 - .s configure -bd 0 -orient horizontal - pack .s -fill x -expand 1 -anchor center - update - set x [.s configure -width] - pack .s -fill x -expand 1 -anchor n - update - set y [.s configure -width] - pack .s -fill x -expand 1 -anchor s - update - list [.s configure -width] $x $y -} {{-width width Width 16 16} {-width width Width 16 16} {-width width Width 16 16}} -test macscroll-1.5 {TkpDisplayScrollbar procedure} {macOnly} { - wm geometry . 300x16 - .s configure -bd 0 -orient horizontal - pack .s -fill x -expand 1 -anchor s - update - wm geometry . 300x15 - update - wm geometry . 300x14 - update -} {} -test macscroll-1.6 {TkpDisplayScrollbar procedure} {macOnly} { - # Check the drawing of the resize hack - wm geometry . 20x300 - wm resizable . 1 1 - .s configure -bd 0 -orient vertical - pack .s -fill y -expand 1 -anchor e - update - set x [.s identify 12 295] - wm resizable . 0 0 - update - set y [.s identify 12 295] - wm resizable . 1 1 - pack .s -fill y -expand 1 -anchor center - update - list $x $y [.s identify 12 295] -} {{} arrow2 arrow2} -test macscroll-1.7 {TkpDisplayScrollbar procedure} {macOnly} { - wm geometry . 300x300 - pack .s -fill y -expand 1 -anchor e - catch {destroy .s2} - scrollbar .s2 -orient horizontal - place .s2 -x 0 -y 284 -width 300 -} {} - -deleteWindows -# cleanup -::tcltest::cleanupTests -return diff --git a/tests/main.test b/tests/main.test index 3799be7..1d33fbb 100644 --- a/tests/main.test +++ b/tests/main.test @@ -9,28 +9,93 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::interpreter -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile - -test main-1.1 {StdinProc} {unix} { +test main-1.1 {StdinProc} -constraints stdio -setup { set script [makeFile { close stdin; exit } script] - if {[catch {exec [interpreter] <$script} msg]} { - set error 1 - } else { - set error 0 - } +} -body { + list [catch {exec [interpreter] <$script} msg] $msg +} -cleanup { removeFile script - list $error $msg -} {0 {}} +} -result {0 {}} + +test main-2.1 {Tk_MainEx: -encoding option} -constraints { + stdio + } -setup { + set script [makeFile {} script] + file delete $script + set f [open $script w] + fconfigure $f -encoding utf-8 + puts $f {puts [list $argv0 $argv $tcl_interactive]} + puts -nonewline $f {puts [string equal \u20ac } + puts $f "\u20ac]; exit" + close $f + catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]} + } -body { + read $f + } -cleanup { + close $f + removeFile script + } -result [list script {} 0]\n1\n + +test main-2.2 {Tk_MainEx: -encoding option} -constraints { + stdio + } -setup { + set script [makeFile {} script] + file delete $script + set f [open $script w] + fconfigure $f -encoding utf-8 + puts $f {puts [list $argv0 $argv $tcl_interactive]} + puts -nonewline $f {puts [string equal \u20ac } + puts $f "\u20ac]; exit" + close $f + catch {set f [open "|[list [interpreter] -encoding ascii script]" r]} + } -body { + read $f + } -cleanup { + close $f + removeFile script + } -result [list script {} 0]\n0\n + + # Procedure to simulate interactive typing of commands, line by line + proc type {chan script} { + foreach line [split $script \n] { + if {[catch { + puts $chan $line + flush $chan + }]} { + return + } + # Grrr... Behavior depends on this value. + after 1000 + } + } + +test main-2.3 {Tk_MainEx: -encoding option} -constraints { + stdio + } -setup { + set script [makeFile {} script] + file delete $script + set f [open $script w] + fconfigure $f -encoding utf-8 + puts $f {puts [list $argv0 $argv $tcl_interactive]} + puts -nonewline $f {puts [string equal \u20ac } + puts $f "\u20ac]" + close $f + catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]} + } -body { + type $f { + puts $argv + exit + } + list [catch {gets $f} line] $line + } -cleanup { + close $f + removeFile script + } -result {0 {-enc utf-8 script}} test main-3.1 {Tk_ParseArgv: -help option} -constraints unix -body { # Run only on unix as Win32 pops up native dialog @@ -57,5 +122,5 @@ test main-3.3 {Tk_ParseArgv: -help option} -setup { } -match glob -result {1 {Command-specific options:*}} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/menu.test b/tests/menu.test index 98978c5..3cb47c3 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -6,12 +6,13 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands +# find the earth.gif file for use in these tests +set earthPhotoFile [file join [file dirname [info script]] earth.gif] +testConstraint hasEarthPhoto [file exists $earthPhotoFile] + test menu-1.1 {Tk_MenuCmd procedure} { list [catch menu msg] $msg } {1 {wrong # args: should be "menu pathName ?options?"}} @@ -196,7 +197,9 @@ menu .m2 .m1 add separator .m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off .m1 add radiobutton -label "radiobutton" -variable radio -image create photo image1 -file [file join $tk_library demos images earth.gif] +if {[testConstraint hasEarthPhoto]} { + image create photo image1 -file $earthPhotoFile +} foreach configTest { {-activebackground @@ -489,7 +492,9 @@ foreach configTest { set options [lindex $attempt 1] foreach item {0 1 2 3 4 5} { catch {unset msg} - test menu-2.$i [list entry configuration options $name $item $value [.m1 type $item]] { + # OK, it's an overeager constraint, but it should also + # normally hold anyway + test menu-2.$i [list entry configuration options $name $item $value [.m1 type $item]] hasEarthPhoto { set result [catch {.m1 entryconfigure $item $name $value} msg] if {$result == 1} { set msg @@ -502,7 +507,9 @@ foreach configTest { } } -image delete image1 +if {[testConstraint hasEarthPhoto]} { + image delete image1 +} destroy .m1 destroy .m2 @@ -672,6 +679,17 @@ test menu-3.29 {MenuWidgetCmd procedure, "delete" option} { .m1 activate 3 list [catch {.m1 delete 1} msg] $msg [destroy .m1] } {0 {} {}} +test menu-3.29+1 {MenuWidgetCmd, "delete", Bug 220950} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 add command -label "bogus" + .m1 add command -label "ok" + .m1 delete 10 20 + .m1 entrycget last -label +} -cleanup { + destroy .m1 +} -result ok test menu-3.30 {MenuWidgetCmd procedure, "entrycget" option} { catch {destroy .m1} menu .m1 @@ -888,7 +906,7 @@ test menu-3.67 {MenuWidgetCmd procedure, bad option} { catch {destroy .m1} menu .m1 list [catch {.m1 foo} msg] $msg [destroy .m1] -} {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, or yposition} {}} +} {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition} {}} test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} { set t .t set m1 .t.m1 @@ -908,6 +926,23 @@ test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} { destroy $t; set l; } {1 1} +test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup { + catch {destroy .m1} + menu .m1 +} -body { + .m1 xposition +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 xposition index"} +test menu-3.70 {MenuWidgetCmd procedure, "xposition" option} -setup { + catch {destroy .m1} + menu .m1 +} -body { + .m1 xposition 1 + subst {} ;# just checking that the xposition does not produce an error... +} -cleanup { + destroy .m1 +} -result {} test menu-4.1 {TkInvokeMenu: disabled} { catch {destroy .m1} @@ -1345,10 +1380,10 @@ test menu-8.1 {DestroyMenuEntry} { .m1 add cascade -menu .m2 list [catch {.m1 delete 1} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-8.2 {DestroyMenuEntry} { +test menu-8.2 {DestroyMenuEntry} hasEarthPhoto { catch {image delete image1a} catch {destroy .m1} - image create photo image1a -file [file join $tk_library demos images earth.gif] + image create photo image1a -file $earthPhotoFile menu .m1 .m1 add command -image image1a list [catch {.m1 delete 1} msg] $msg [destroy .m1] [image delete image1a] @@ -1597,32 +1632,32 @@ test menu-11.18 {ConfigureMenuEntry} testImageType { image create test image1 list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1] } {0 {} {} {}} -test menu-11.19 {ConfigureMenuEntry} testImageType { +test menu-11.19 {ConfigureMenuEntry} {testImageType hasEarthPhoto} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} image create test image1 - image create photo image2 -file [file join $tk_library demos images earth.gif] + image create photo image2 -file $earthPhotoFile menu .m1 .m1 add command -image image1 list [catch {.m1 entryconfigure 1 -image image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-11.20 {ConfigureMenuEntry} testImageType { +test menu-11.20 {ConfigureMenuEntry} {testImageType hasEarthPhoto} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} - image create photo image1 -file [file join $tk_library demos images earth.gif] + image create photo image1 -file $earthPhotoFile image create test image2 menu .m1 .m1 add checkbutton -image image1 list [catch {.m1 entryconfigure 1 -selectimage image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-11.21 {ConfigureMenuEntry} testImageType { +test menu-11.21 {ConfigureMenuEntry} {testImageType hasEarthPhoto} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} catch {image delete image3} - image create photo image1 -file [file join $tk_library demos images earth.gif] + image create photo image1 -file $earthPhotoFile image create test image2 image create test image3 menu .m1 @@ -2042,23 +2077,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} @@ -2066,7 +2101,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} @@ -2107,6 +2142,38 @@ test menu-22.2 {GetIndexFromCoords} { .m1 configure -tearoff 0 list [catch {.m1 index @5,5} msg] $msg [destroy .m1] } {0 0 {}} +test menu-22.3 {GetIndexFromCoords: mapped window, y only} unix { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 configure -tearoff 0 + tk_popup .m1 0 0 + tkwait visibility .m1 + list [catch {.m1 index @5} msg] $msg [destroy .m1] +} {0 0 {}} +test menu-22.4 {GetIndexFromCoords: mapped window x,y} unix { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 configure -tearoff 0 + tk_popup .m1 0 0 + tkwait visibility .m1 + update + set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}] + list [catch {.m1 index @$x,5} msg] $msg [destroy .m1] +} {0 0 {}} +test menu-22.5 {GetIndexFromCoords: mapped wide window} unix { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 configure -tearoff 0 + tk_popup .m1 0 0 + tkwait visibility .m1 + wm geometry .m1 200x100 + update + set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}] + list [catch {.m1 index @$x,5} msg] $msg [destroy .m1] +} {0 0 {}} test menu-23.1 {RecursivelyDeleteMenu} { catch {destroy .m1} @@ -2496,5 +2563,5 @@ test menu-36.1 {menu -underline string overruns Bug 1599877} {} { # cleanup deleteWindows -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/menuDraw.test b/tests/menuDraw.test index 945ac3f..225223c 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -6,10 +6,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands test menuDraw-1.1 {TkMenuInitializeDrawingFields} { @@ -164,7 +161,7 @@ test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} { } {{} {}} -test menuDraw-8.1 {TkRecomputeMenu} {pcOnly userInteraction} { +test menuDraw-8.1 {TkRecomputeMenu} {win userInteraction} { catch {destroy .m1} menu .m1 .m1 configure -postcommand [.m1 add command -label foo] @@ -255,7 +252,7 @@ test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} testImageType { } {{} {} {}} #Don't know how to test missing tkwin in DisplayMenu -test menuDraw-12.1 {DisplayMenu - menubar background} {unixOnly} { +test menuDraw-12.1 {DisplayMenu - menubar background} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label foo -menu .m2 @@ -313,7 +310,7 @@ test menuDraw.12.7 {DisplayMenu - three columns} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test menuDraw-12.6 {Display menu - testing for extra space and menubars} {unixOnly} { +test menuDraw-12.6 {Display menu - testing for extra space and menubars} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label foo @@ -347,14 +344,6 @@ test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} { set tearoff [tk::TearOffMenu .m1 40 40] list [wm geometry $tearoff 200x100] [update] [destroy .m1] } {{} {} {}} -test menuDraw-13.3 {TkMenuEventProc - ActivateNotify} {macOnly} { - catch {destroy .t2} - toplevel .t2 -menu .t2.m1 - menu .t2.m1 - .t2.m1 add command -label foo - tk::TearOffMenu .t2.m1 40 40 - list [catch {update} msg] $msg [destroy .t2] -} {0 {} {}} # Testing deletes is hard, and I am going to do my best. Don't know how # to test the case where we have already cleared the tkwin field in the # menuPtr. @@ -431,7 +420,7 @@ test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} { } {0 {}} -test menuDraw-16.1 {TkPostSubmenu} {unixOnly} { +test menuDraw-16.1 {TkPostSubmenu} nonUnixUserInteraction { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -442,7 +431,7 @@ test menuDraw-16.1 {TkPostSubmenu} {unixOnly} { $tearoff postcascade 0 list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] } {{} {} {}} -test menuDraw-16.2 {TkPostSubMenu} {unixOnly} { +test menuDraw-16.2 {TkPostSubMenu} nonUnixUserInteraction { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -470,7 +459,7 @@ test menuDraw-16.4 {TkPostSubMenu} { set tearoff [tk::TearOffMenu .m1 40 40] list [$tearoff postcascade 0] [destroy .m1] } {{} {}} -test menuDraw-16.5 {TkPostSubMenu} {unixOnly} { +test menuDraw-16.5 {TkPostSubMenu} unix { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -479,7 +468,7 @@ test menuDraw-16.5 {TkPostSubMenu} {unixOnly} { set tearoff [tk::TearOffMenu .m1 40 40] list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2] } {1 {invalid command name "glorp"} {} {}} -test menuDraw-16.6 {TkPostSubMenu} {pcOnly userInteraction} { +test menuDraw-16.6 {TkPostSubMenu} {win userInteraction} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -490,7 +479,7 @@ test menuDraw-16.6 {TkPostSubMenu} {pcOnly userInteraction} { list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] } {{} {} {}} -test menuDraw-17.1 {AdjustMenuCoords - menubar} {unixOnly} { +test menuDraw-17.1 {AdjustMenuCoords - menubar} unix { catch {destroy .m1} catch {destroy .m2} menu .m1 -tearoff 0 @@ -505,7 +494,7 @@ test menuDraw-17.1 {AdjustMenuCoords - menubar} {unixOnly} { } list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2] } {{} {} {} {}} -test menuDraw-17.2 {AdjustMenuCoords - menu} {pcOnly userInteraction} { +test menuDraw-17.2 {AdjustMenuCoords - menu} {win userInteraction} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -518,18 +507,5 @@ test menuDraw-17.2 {AdjustMenuCoords - menu} {pcOnly userInteraction} { # cleanup deleteWindows -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/menubut.test b/tests/menubut.test index 14a03a1..3dfa1b5 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -11,10 +11,7 @@ # XXX but many procedures have no tests. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # Create entries in the option database to be sure that geometry options @@ -303,7 +300,7 @@ test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {nonPortable fonts} { pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {78 28} -test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {testImageType unixOnly nonPortable} { +test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {testImageType unix nonPortable} { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. @@ -313,7 +310,7 @@ test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {testImageType unixOn pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {64 23} -test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {testImageType pcOnly nonPortable} { +test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {testImageType win nonPortable} { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. @@ -340,18 +337,5 @@ deleteWindows option clear # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/message.test b/tests/message.test index 1d6e626..93344c4 100644 --- a/tests/message.test +++ b/tests/message.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands option add *Message.borderWidth 2 @@ -119,5 +116,5 @@ test message-3.7 {MessageWidgetObjCmd procedure, "configure"} { } {4} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/msgbox.test b/tests/msgbox.test index b15c61d..ec98c89 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -6,28 +6,25 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands test msgbox-1.1 {tk_messageBox command} { list [catch {tk_messageBox -foo} msg] $msg -} {1 {bad option "-foo": must be -default, -icon, -message, -parent, -title, or -type}} +} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}} test msgbox-1.2 {tk_messageBox command} { list [catch {tk_messageBox -foo bar} msg] $msg -} {1 {bad option "-foo": must be -default, -icon, -message, -parent, -title, or -type}} +} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}} catch {tk_messageBox -foo bar} msg regsub -all , $msg "" options regsub \"-foo\" $options "" options foreach option $options { - if {[string index $option 0] == "-"} { - test msgbox-1.3 {tk_messageBox command} { - list [catch {tk_messageBox $option} msg] $msg - } [list 1 "value for \"$option\" missing"] + 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 +64,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 +126,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,14 +162,14 @@ 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 -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/obj.test b/tests/obj.test index e6eac27..25bd70f 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -6,10 +6,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands test obj-1.1 {TkGetPixelsFromObj} { @@ -29,19 +26,5 @@ test obj-4.1 {SetPixelFromAny} { deleteWindows # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - - diff --git a/tests/oldpack.test b/tests/oldpack.test index 694bb94..2f9b979 100644 --- a/tests/oldpack.test +++ b/tests/oldpack.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # First, test a single window packed in various ways in a parent @@ -32,22 +29,22 @@ frame .pack.violet -width 80 -height 20 label .pack.violet.l -text P -bd 2 -relief raised place .pack.violet.l -relwidth 1.0 -relheight 1.0 -test pack-1.1 {basic positioning} { +test oldpack-1.1 {basic positioning} { pack ap .pack .pack.red top update winfo geometry .pack.red } 10x20+45+0 -test pack-1.2 {basic positioning} { +test oldpack-1.2 {basic positioning} { pack append .pack .pack.red bottom update winfo geometry .pack.red } 10x20+45+80 -test pack-1.3 {basic positioning} { +test oldpack-1.3 {basic positioning} { pack append .pack .pack.red left update winfo geometry .pack.red } 10x20+0+40 -test pack-1.4 {basic positioning} { +test oldpack-1.4 {basic positioning} { pack append .pack .pack.red right update winfo geometry .pack.red @@ -56,22 +53,22 @@ test pack-1.4 {basic positioning} { # Try adding padding around the window and make sure that the # window gets a larger frame. -test pack-2.1 {padding} { +test oldpack-2.1 {padding} { pack append .pack .pack.red {t padx 20} update winfo geometry .pack.red } 10x20+45+0 -test pack-2.2 {padding} { +test oldpack-2.2 {padding} { pack append .pack .pack.red {top pady 20} update winfo geometry .pack.red } 10x20+45+10 -test pack-2.3 {padding} { +test oldpack-2.3 {padding} { pack append .pack .pack.red {l padx 20} update winfo geometry .pack.red } 10x20+10+40 -test pack-2.4 {padding} { +test oldpack-2.4 {padding} { pack append .pack .pack.red {left pady 20} update winfo geometry .pack.red @@ -81,102 +78,102 @@ test pack-2.4 {padding} { # make sure they all work. Try two differenet frame locations, # to make sure that frame offsets are being added in correctly. -test pack-3.1 {framing} { +test oldpack-3.1 {framing} { pack append .pack .pack.red {b padx 20 pady 30} update winfo geometry .pack.red } 10x20+45+65 -test pack-3.2 {framing} { +test oldpack-3.2 {framing} { pack append .pack .pack.red {bottom padx 20 pady 30 fr n} update winfo geometry .pack.red } 10x20+45+50 -test pack-3.3 {framing} { +test oldpack-3.3 {framing} { pack append .pack .pack.red {bottom padx 20 pady 30 frame ne} update winfo geometry .pack.red } 10x20+90+50 -test pack-3.4 {framing} { +test oldpack-3.4 {framing} { pack append .pack .pack.red {bottom padx 20 pady 30 frame e} update winfo geometry .pack.red } 10x20+90+65 -test pack-3.5 {framing} { +test oldpack-3.5 {framing} { pack append .pack .pack.red {bottom padx 20 pady 30 frame se} update winfo geometry .pack.red } 10x20+90+80 -test pack-3.6 {framing} { +test oldpack-3.6 {framing} { pack append .pack .pack.red {bottom padx 20 pady 30 frame s} update winfo geometry .pack.red } 10x20+45+80 -test pack-3.7 {framing} { +test oldpack-3.7 {framing} { pack append .pack .pack.red {bottom padx 20 pady 30 frame sw} update winfo geometry .pack.red } 10x20+0+80 -test pack-3.8 {framing} { +test oldpack-3.8 {framing} { pack append .pack .pack.red {bottom padx 20 pady 30 frame w} update winfo geometry .pack.red } 10x20+0+65 -test pack-3.9 {framing} { +test oldpack-3.9 {framing} { pack append .pack .pack.red {bottom padx 20 pady 30 frame nw} update winfo geometry .pack.red } 10x20+0+50 -test pack-3.10 {framing} { +test oldpack-3.10 {framing} { pack append .pack .pack.red {bottom padx 20 pady 30 frame c} update winfo geometry .pack.red } 10x20+45+65 -test pack-3.11 {framing} { +test oldpack-3.11 {framing} { pack append .pack .pack.red {r padx 20 pady 30} update winfo geometry .pack.red } 10x20+80+40 -test pack-3.12 {framing} { +test oldpack-3.12 {framing} { pack append .pack .pack.red {right padx 20 pady 30 frame n} update winfo geometry .pack.red } 10x20+80+0 -test pack-3.13 {framing} { +test oldpack-3.13 {framing} { pack append .pack .pack.red {right padx 20 pady 30 frame ne} update winfo geometry .pack.red } 10x20+90+0 -test pack-3.14 {framing} { +test oldpack-3.14 {framing} { pack append .pack .pack.red {right padx 20 pady 30 frame e} update winfo geometry .pack.red } 10x20+90+40 -test pack-3.15 {framing} { +test oldpack-3.15 {framing} { pack append .pack .pack.red {right padx 20 pady 30 frame se} update winfo geometry .pack.red } 10x20+90+80 -test pack-3.16 {framing} { +test oldpack-3.16 {framing} { pack append .pack .pack.red {right padx 20 pady 30 frame s} update winfo geometry .pack.red } 10x20+80+80 -test pack-3.17 {framing} { +test oldpack-3.17 {framing} { pack append .pack .pack.red {right padx 20 pady 30 frame sw} update winfo geometry .pack.red } 10x20+70+80 -test pack-3.18 {framing} { +test oldpack-3.18 {framing} { pack append .pack .pack.red {right padx 20 pady 30 frame w} update winfo geometry .pack.red } 10x20+70+40 -test pack-3.19 {framing} { +test oldpack-3.19 {framing} { pack append .pack .pack.red {right padx 20 pady 30 frame nw} update winfo geometry .pack.red } 10x20+70+0 -test pack-3.20 {framing} { +test oldpack-3.20 {framing} { pack append .pack .pack.red {right padx 20 pady 30 frame center} update winfo geometry .pack.red @@ -185,32 +182,32 @@ test pack-3.20 {framing} { # Try out various filling combinations in a couple of different # frame locations. -test pack-4.1 {filling} { +test oldpack-4.1 {filling} { pack append .pack .pack.red {bottom padx 20 pady 30 fillx} update winfo geometry .pack.red } 100x20+0+65 -test pack-4.2 {filling} { +test oldpack-4.2 {filling} { pack append .pack .pack.red {bottom padx 20 pady 30 filly} update winfo geometry .pack.red } 10x50+45+50 -test pack-4.3 {filling} { +test oldpack-4.3 {filling} { pack append .pack .pack.red {bottom padx 20 pady 30 fill} update winfo geometry .pack.red } 100x50+0+50 -test pack-4.4 {filling} { +test oldpack-4.4 {filling} { pack append .pack .pack.red {right padx 20 pady 30 fillx} update winfo geometry .pack.red } 30x20+70+40 -test pack-4.5 {filling} { +test oldpack-4.5 {filling} { pack append .pack .pack.red {right padx 20 pady 30 filly} update winfo geometry .pack.red } 10x100+80+0 -test pack-4.6 {filling} { +test oldpack-4.6 {filling} { pack append .pack .pack.red {right padx 20 pady 30 fill} update winfo geometry .pack.red @@ -224,55 +221,55 @@ test pack-4.6 {filling} { pack append .pack .pack.red top .pack.green top .pack.blue top \ .pack.violet top update -test pack-5.1 {multiple windows} {winfo geometry .pack.red} 10x20+45+0 -test pack-5.2 {multiple windows} {winfo geometry .pack.green} 30x40+35+20 -test pack-5.3 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60 -test pack-5.4 {multiple windows} {winfo ismapped .pack.violet} 0 +test oldpack-5.1 {multiple windows} {winfo geometry .pack.red} 10x20+45+0 +test oldpack-5.2 {multiple windows} {winfo geometry .pack.green} 30x40+35+20 +test oldpack-5.3 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60 +test oldpack-5.4 {multiple windows} {winfo ismapped .pack.violet} 0 pack b .pack.blue .pack.violet top update -test pack-5.5 {multiple windows} {winfo ismapped .pack.violet} 1 -test pack-5.6 {multiple windows} {winfo geometry .pack.violet} 80x20+10+60 -test pack-5.7 {multiple windows} {winfo geometry .pack.blue} 40x20+30+80 +test oldpack-5.5 {multiple windows} {winfo ismapped .pack.violet} 1 +test oldpack-5.6 {multiple windows} {winfo geometry .pack.violet} 80x20+10+60 +test oldpack-5.7 {multiple windows} {winfo geometry .pack.blue} 40x20+30+80 pack after .pack.blue .pack.red top update -test pack-5.8 {multiple windows} {winfo geometry .pack.green} 30x40+35+0 -test pack-5.9 {multiple windows} {winfo geometry .pack.violet} 80x20+10+40 -test pack-5.10 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60 -test pack-5.11 {multiple windows} {winfo ismapped .pack.red} 0 +test oldpack-5.8 {multiple windows} {winfo geometry .pack.green} 30x40+35+0 +test oldpack-5.9 {multiple windows} {winfo geometry .pack.violet} 80x20+10+40 +test oldpack-5.10 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60 +test oldpack-5.11 {multiple windows} {winfo ismapped .pack.red} 0 pack before .pack.green .pack.red right .pack.blue left update -test pack-5.12 {multiple windows} {winfo ismapped .pack.red} 1 -test pack-5.13 {multiple windows} {winfo geometry .pack.red} 10x20+90+40 -test pack-5.14 {multiple windows} {winfo geometry .pack.blue} 40x40+0+30 -test pack-5.15 {multiple windows} {winfo geometry .pack.green} 30x40+50+0 -test pack-5.16 {multiple windows} {winfo geometry .pack.violet} 50x20+40+40 +test oldpack-5.12 {multiple windows} {winfo ismapped .pack.red} 1 +test oldpack-5.13 {multiple windows} {winfo geometry .pack.red} 10x20+90+40 +test oldpack-5.14 {multiple windows} {winfo geometry .pack.blue} 40x40+0+30 +test oldpack-5.15 {multiple windows} {winfo geometry .pack.green} 30x40+50+0 +test oldpack-5.16 {multiple windows} {winfo geometry .pack.violet} 50x20+40+40 pack append .pack .pack.violet left .pack.green bottom .pack.red bottom \ .pack.blue bottom update -test pack-5.17 {multiple windows} {winfo geometry .pack.violet} 80x20+0+40 -test pack-5.18 {multiple windows} {winfo geometry .pack.green} 20x40+80+60 -test pack-5.19 {multiple windows} {winfo geometry .pack.red} 10x20+85+40 -test pack-5.20 {multiple windows} {winfo geometry .pack.blue} 20x40+80+0 +test oldpack-5.17 {multiple windows} {winfo geometry .pack.violet} 80x20+0+40 +test oldpack-5.18 {multiple windows} {winfo geometry .pack.green} 20x40+80+60 +test oldpack-5.19 {multiple windows} {winfo geometry .pack.red} 10x20+85+40 +test oldpack-5.20 {multiple windows} {winfo geometry .pack.blue} 20x40+80+0 pack after .pack.blue .pack.blue top .pack.red right .pack.green right \ .pack.violet right update -test pack-5.21 {multiple windows} {winfo geometry .pack.blue} 40x40+30+0 -test pack-5.22 {multiple windows} {winfo geometry .pack.red} 10x20+90+60 -test pack-5.23 {multiple windows} {winfo geometry .pack.green} 30x40+60+50 -test pack-5.24 {multiple windows} {winfo geometry .pack.violet} 60x20+0+60 +test oldpack-5.21 {multiple windows} {winfo geometry .pack.blue} 40x40+30+0 +test oldpack-5.22 {multiple windows} {winfo geometry .pack.red} 10x20+90+60 +test oldpack-5.23 {multiple windows} {winfo geometry .pack.green} 30x40+60+50 +test oldpack-5.24 {multiple windows} {winfo geometry .pack.violet} 60x20+0+60 pack after .pack.blue .pack.red left .pack.green left .pack.violet left update -test pack-5.25 {multiple windows} {winfo geometry .pack.blue} 40x40+30+0 -test pack-5.26 {multiple windows} {winfo geometry .pack.red} 10x20+0+60 -test pack-5.27 {multiple windows} {winfo geometry .pack.green} 30x40+10+50 -test pack-5.28 {multiple windows} {winfo geometry .pack.violet} 60x20+40+60 +test oldpack-5.25 {multiple windows} {winfo geometry .pack.blue} 40x40+30+0 +test oldpack-5.26 {multiple windows} {winfo geometry .pack.red} 10x20+0+60 +test oldpack-5.27 {multiple windows} {winfo geometry .pack.green} 30x40+10+50 +test oldpack-5.28 {multiple windows} {winfo geometry .pack.violet} 60x20+40+60 pack append .pack .pack.violet left .pack.green left .pack.blue left \ .pack.red left update -test pack-5.29 {multiple windows} {winfo geometry .pack.violet} 80x20+0+40 -test pack-5.30 {multiple windows} {winfo geometry .pack.green} 20x40+80+30 -test pack-5.31 {multiple windows} {winfo ismapped .pack.blue} 0 -test pack-5.32 {multiple windows} {winfo ismapped .pack.red} 0 +test oldpack-5.29 {multiple windows} {winfo geometry .pack.violet} 80x20+0+40 +test oldpack-5.30 {multiple windows} {winfo geometry .pack.green} 20x40+80+30 +test oldpack-5.31 {multiple windows} {winfo ismapped .pack.blue} 0 +test oldpack-5.32 {multiple windows} {winfo ismapped .pack.red} 0 # Test the ability of the packer to propagate geometry information @@ -284,25 +281,25 @@ test pack-5.32 {multiple windows} {winfo ismapped .pack.red} 0 pack append .pack .pack.red top .pack.green top .pack.blue top \ .pack.violet top update -test pack-6.1 {geometry propagation} {winfo reqwidth .pack} 80 -test pack-6.2 {geometry propagation} {winfo reqheight .pack} 120 +test oldpack-6.1 {geometry propagation} {winfo reqwidth .pack} 80 +test oldpack-6.2 {geometry propagation} {winfo reqheight .pack} 120 destroy .pack.violet update -test pack-6.3 {geometry propagation} {winfo reqwidth .pack} 40 -test pack-6.4 {geometry propagation} {winfo reqheight .pack} 100 +test oldpack-6.3 {geometry propagation} {winfo reqwidth .pack} 40 +test oldpack-6.4 {geometry propagation} {winfo reqheight .pack} 100 frame .pack.violet -width 80 -height 20 -bg violet label .pack.violet.l -text P -bd 2 -relief raised place .pack.violet.l -relwidth 1.0 -relheight 1.0 pack append .pack .pack.red left .pack.green right .pack.blue bottom \ .pack.violet top update -test pack-6.5 {geometry propagation} {winfo reqwidth .pack} 120 -test pack-6.6 {geometry propagation} {winfo reqheight .pack} 60 +test oldpack-6.5 {geometry propagation} {winfo reqwidth .pack} 120 +test oldpack-6.6 {geometry propagation} {winfo reqheight .pack} 60 pack append .pack .pack.violet top .pack.green top .pack.blue left \ .pack.red left update -test pack-6.7 {geometry propagation} {winfo reqwidth .pack} 80 -test pack-6.8 {geometry propagation} {winfo reqheight .pack} 100 +test oldpack-6.7 {geometry propagation} {winfo reqwidth .pack} 80 +test oldpack-6.8 {geometry propagation} {winfo reqheight .pack} 100 # Test the "expand" option, and make sure space is evenly divided # when several windows request expansion. @@ -310,21 +307,21 @@ test pack-6.8 {geometry propagation} {winfo reqheight .pack} 100 pack append .pack .pack.violet top .pack.green {left e} \ .pack.blue {left expand} .pack.red {left expand} update -test pack-7.1 {multiple expanded windows} { +test oldpack-7.1 {multiple expanded windows} { pack append .pack .pack.violet top .pack.green {left e} \ .pack.blue {left expand} .pack.red {left expand} update list [winfo geometry .pack.green] [winfo geometry .pack.blue] \ [winfo geometry .pack.red] } {30x40+3+40 40x40+39+40 10x20+86+50} -test pack-7.2 {multiple expanded windows} { +test oldpack-7.2 {multiple expanded windows} { pack append .pack .pack.green left .pack.violet {bottom expand} \ .pack.blue {bottom expand} .pack.red {bottom expand} update list [winfo geometry .pack.violet] [winfo geometry .pack.blue] \ [winfo geometry .pack.red] } {70x20+30+77 40x40+45+30 10x20+60+3} -test pack-7.3 {multiple expanded windows} { +test oldpack-7.3 {multiple expanded windows} { foreach i [winfo child .pack] { pack unpack $i } @@ -334,7 +331,7 @@ test pack-7.3 {multiple expanded windows} { list [winfo geometry .pack.green] [winfo geometry .pack.red] \ [winfo geometry .pack.blue] } {40x100+0+0 20x100+40+0 40x40+60+0} -test pack-7.4 {multiple expanded windows} { +test oldpack-7.4 {multiple expanded windows} { foreach i [winfo child .pack] { pack unpack $i } @@ -344,7 +341,7 @@ test pack-7.4 {multiple expanded windows} { list [winfo geometry .pack.red] [winfo geometry .pack.violet] \ [winfo geometry .pack.blue] } {10x20+45+5 80x20+10+35 40x40+60+60} -test pack-7.5 {multiple expanded windows} { +test oldpack-7.5 {multiple expanded windows} { foreach i [winfo child .pack] { pack unpack $i } @@ -352,7 +349,7 @@ test pack-7.5 {multiple expanded windows} { update list [winfo geometry .pack.green] [winfo geometry .pack.red] } {30x40+70+60 10x20+30+40} -test pack-7.6 {multiple expanded windows} { +test oldpack-7.6 {multiple expanded windows} { foreach i [winfo child .pack] { pack unpack $i } @@ -367,116 +364,116 @@ test pack-7.6 {multiple expanded windows} { # Syntax errors on pack commands -test pack-8.1 {syntax errors} { +test oldpack-8.1 {syntax errors} { set msg "" set result [catch {pack} msg] concat $result $msg } {1 wrong # args: should be "pack option arg ?arg ...?"} -test pack-8.2 {syntax errors} { +test oldpack-8.2 {syntax errors} { set msg "" set result [catch {pack append} msg] concat $result $msg } {1 wrong # args: should be "pack option arg ?arg ...?"} -test pack-8.3 {syntax errors} { +test oldpack-8.3 {syntax errors} { set msg "" set result [catch {pack gorp foo} msg] concat $result $msg } {1 bad option "gorp": must be configure, forget, info, propagate, or slaves} -test pack-8.4 {syntax errors} { +test oldpack-8.4 {syntax errors} { set msg "" set result [catch {pack a .pack} msg] concat $result $msg } {1 bad option "a": must be configure, forget, info, propagate, or slaves} -test pack-8.5 {syntax errors} { +test oldpack-8.5 {syntax errors} { set msg "" set result [catch {pack after foobar} msg] concat $result $msg } {1 bad window path name "foobar"} -test pack-8.6 {syntax errors} { +test oldpack-8.6 {syntax errors} { frame .pack.yellow -bg yellow set msg "" set result [catch {pack after .pack.yellow} msg] destroy .pack.yellow concat $result $msg } {1 window ".pack.yellow" isn't packed} -test pack-8.7 {syntax errors} { +test oldpack-8.7 {syntax errors} { set msg "" set result [catch {pack append foobar} msg] concat $result $msg } {1 bad window path name "foobar"} -test pack-8.8 {syntax errors} { +test oldpack-8.8 {syntax errors} { set msg "" set result [catch {pack before foobar} msg] concat $result $msg } {1 bad window path name "foobar"} -test pack-8.9 {syntax errors} { +test oldpack-8.9 {syntax errors} { frame .pack.yellow -bg yellow set msg "" set result [catch {pack before .pack.yellow} msg] destroy .pack.yellow concat $result $msg } {1 window ".pack.yellow" isn't packed} -test pack-8.10 {syntax errors} { +test oldpack-8.10 {syntax errors} { set msg "" set result [catch {pack info .pack help} msg] concat $result $msg } {1 wrong # args: should be "pack info window"} -test pack-8.11 {syntax errors} { +test oldpack-8.11 {syntax errors} { set msg "" set result [catch {pack info foobar} msg] concat $result $msg } {1 bad window path name "foobar"} -test pack-8.12 {syntax errors} { +test oldpack-8.12 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue} msg] concat $result $msg } {1 wrong # args: window ".pack.blue" should be followed by options} -test pack-8.13 {syntax errors} { +test oldpack-8.13 {syntax errors} { set msg "" set result [catch {pack append . .pack.blue top} msg] concat $result $msg } {1 can't pack .pack.blue inside .} -test pack-8.14 {syntax errors} { +test oldpack-8.14 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue f} msg] concat $result $msg } {1 bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame} -test pack-8.15 {syntax errors} { +test oldpack-8.15 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue pad} msg] concat $result $msg } {1 bad option "pad": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame} -test pack-8.16 {syntax errors} { +test oldpack-8.16 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue {frame south}} msg] concat $result $msg } {1 bad anchor "south": must be n, ne, e, se, s, sw, w, nw, or center} -test pack-8.17 {syntax errors} { +test oldpack-8.17 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue {padx -2}} msg] concat $result $msg } {1 bad pad value "-2": must be positive screen distance} -test pack-8.18 {syntax errors} { +test oldpack-8.18 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue {padx}} msg] concat $result $msg } {1 wrong # args: "padx" option must be followed by screen distance} -test pack-8.19 {syntax errors} { +test oldpack-8.19 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue {pady -2}} msg] concat $result $msg } {1 bad pad value "-2": must be positive screen distance} -test pack-8.20 {syntax errors} { +test oldpack-8.20 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue {pady}} msg] concat $result $msg } {1 wrong # args: "pady" option must be followed by screen distance} -test pack-8.21 {syntax errors} { +test oldpack-8.21 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue "\{abc"} msg] concat $result $msg } {1 unmatched open brace in list} -test pack-8.22 {syntax errors} { +test oldpack-8.22 {syntax errors} { set msg "" set result [catch {pack append .pack .pack.blue frame} msg] concat $result $msg @@ -484,21 +481,21 @@ test pack-8.22 {syntax errors} { # Test "pack info" command output. -test pack-9.1 {information output} { +test oldpack-9.1 {information output} { pack append .pack .pack.blue {top fillx frame n} \ .pack.red {bottom filly frame s} .pack.green {left fill frame w} \ .pack.violet {right expand frame e} list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \ [pack info .pack.green] [pack info .pack.violet] } {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor n -expand 0 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor s -expand 0 -fill y -ipadx 0 -ipady 0 -padx 0 -pady 0 -side bottom} {-in .pack -anchor w -expand 0 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side left} {-in .pack -anchor e -expand 1 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side right}} -test pack-9.2 {information output} { +test oldpack-9.2 {information output} { pack append .pack .pack.blue {padx 10 frame nw} \ .pack.red {pady 20 frame ne} .pack.green {frame se} \ .pack.violet {frame sw} list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \ [pack info .pack.green] [pack info .pack.violet] } {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor nw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 5 -pady 0 -side top} {-in .pack -anchor ne -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 10 -side top} {-in .pack -anchor se -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor sw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}} -test pack-9.3 {information output} { +test oldpack-9.3 {information output} { pack append .pack .pack.blue {frame center} .pack.red {frame center} \ .pack.green {frame c} .pack.violet {frame c} list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \ @@ -508,18 +505,5 @@ test pack-9.3 {information output} { catch {destroy .pack} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/option.test b/tests/option.test index 0cc2d14..49d2975 100644 --- a/tests/option.test +++ b/tests/option.test @@ -7,14 +7,10 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile +testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}] catch {destroy .op1} catch {destroy .op2} @@ -197,9 +193,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} {} @@ -229,18 +223,5 @@ catch {destroy .op1} catch {destroy .op2} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/pack.test b/tests/pack.test index 1784b97..edb9f18 100644 --- a/tests/pack.test +++ b/tests/pack.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # Utility procedures: @@ -133,7 +130,7 @@ test pack-2.11 {x padding and filling} { test pack-2.12 {x padding and filling} { pack1 -side top -ipadx 5 -padx 10 -fill x } {280x40+10+0 300x160+0+40} -test pack-2.12 {x padding and filling} { +test pack-2.12a {x padding and filling} { pack1 -side top -ipadx 5 -padx {5 15} -fill x } {280x40+5+0 300x160+0+40} set pad [winfo pixels .pack 1c] @@ -613,6 +610,12 @@ test pack-10.2 {retaining/clearing configuration state} { pack .pack.a -pady 14 pack info .pack.a } {-in .pack -anchor n -expand 1 -fill both -ipadx 3 -ipady 4 -padx 1 -pady 14 -side bottom} +test pack-10.3 {bad -in window does not change master} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [winfo manager .pack.a] \ + [catch {pack .pack.a -in .pack.a} err] $err \ + [winfo manager .pack.a] +} {{} 1 {can't pack .pack.a inside itself} {}} test pack-11.1 {info option} { pack4 -in .pack @@ -1103,5 +1106,5 @@ foreach i {pack1 pack2 pack3 pack4} { } # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/panedwindow.test b/tests/panedwindow.test index 243da98..c7d84b8 100644 --- a/tests/panedwindow.test +++ b/tests/panedwindow.test @@ -7,73 +7,84 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands set i 1 panedwindow .p -foreach test { - {-background "#ff0000" "#ff0000" non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg "#ff0000" "#ff0000" non-existent {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-handlesize 20 20 badValue {bad screen distance "badValue"}} - {-height 20 20 badValue {bad screen distance "badValue"}} - {-opaqueresize true 1 foo {expected boolean value but got "foo"}} - {-orient horizontal horizontal badValue - {bad orient "badValue": must be horizontal or vertical}} - {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-sashcursor arrow arrow badValue {bad cursor spec "badValue"}} - {-sashpad 1.3 1 badValue {bad screen distance "badValue"}} - {-sashrelief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-sashwidth 10 10 badValue {bad screen distance "badValue"}} - {-showhandle true 1 foo {expected boolean value but got "foo"}} - {-width 402 402 badValue {bad screen distance "badValue"}} +foreach {testName testData} { + panedwindow-1.1 {-background + "#ff0000" "#ff0000" non-existent {unknown color name "non-existent"}} + panedwindow-1.2 {-bd + 4 4 badValue {bad screen distance "badValue"}} + panedwindow-1.3 {-bg + "#ff0000" "#ff0000" non-existent {unknown color name "non-existent"}} + panedwindow-1.4 {-borderwidth + 1.3 1 badValue {bad screen distance "badValue"}} + panedwindow-1.5 {-cursor + arrow arrow badValue {bad cursor spec "badValue"}} + panedwindow-1.6 {-handlesize + 20 20 badValue {bad screen distance "badValue"}} + panedwindow-1.7 {-height + 20 20 badValue {bad screen distance "badValue"}} + panedwindow-1.8 {-opaqueresize + true 1 foo {expected boolean value but got "foo"}} + panedwindow-1.9 {-orient + horizontal horizontal + badValue {bad orient "badValue": must be horizontal or vertical}} + panedwindow-1.10 {-relief + groove groove + 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + panedwindow-1.11 {-sashcursor + arrow arrow badValue {bad cursor spec "badValue"}} + panedwindow-1.12 {-sashpad + 1.3 1 badValue {bad screen distance "badValue"}} + panedwindow-1.13 {-sashrelief + groove groove + 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + panedwindow-1.14 {-sashwidth + 10 10 badValue {bad screen distance "badValue"}} + panedwindow-1.15 {-showhandle + true 1 foo {expected boolean value but got "foo"}} + panedwindow-1.16 {-width + 402 402 badValue {bad screen distance "badValue"}} } { - set name [lindex $test 0] - test panedwindow-1.$i {configuration options} { - .p configure $name [lindex $test 1] - list [lindex [.p configure $name] 4] [.p cget $name] - } [list [lindex $test 2] [lindex $test 2]] - incr i - if {[lindex $test 3] != ""} { - test panedwindow-1.$i {configuration options} { - list [catch {.p configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .p configure $name [lindex [.p configure $name] 3] - incr i + lassign $testData optionName goodIn goodOut badIn badOut + test ${testName}(good) "configuration options: $optionName" { + .p configure $optionName $goodIn + list [lindex [.p configure $optionName] 4] [.p cget $optionName] + } [list $goodOut $goodOut] + test ${testName}(bad) "configuration options: $optionName" -body { + .p configure $optionName $badIn + } -returnCodes error -result $badOut + # Reset to default + .p configure $optionName [lindex [.p configure $optionName] 3] } .p add [button .b] .p add [button .c] -foreach test { - {-after .c .c badValue {bad window path name "badValue"}} - {-before .c .c badValue {bad window path name "badValue"}} - {-height 10 10 badValue {bad screen distance "badValue"}} - {-minsize 10 10 badValue {bad screen distance "badValue"}} - {-padx 1.3 1 badValue {bad screen distance "badValue"}} - {-pady 1.3 1 badValue {bad screen distance "badValue"}} - {-sticky nsew nesw abcd {bad stickyness value "abcd": must be a string containing zero or more of n, e, s, and w}} - {-width 10 10 badValue {bad screen distance "badValue"}} +foreach {testName testData} { + panedwindow-1a.1 {-after .c .c badValue {bad window path name "badValue"}} + panedwindow-1a.2 {-before .c .c badValue {bad window path name "badValue"}} + panedwindow-1a.3 {-height 10 10 badValue {bad screen distance "badValue"}} + panedwindow-1a.4 {-hide false 0 foo {expected boolean value but got "foo"}} + panedwindow-1a.5 {-minsize 10 10 badValue {bad screen distance "badValue"}} + panedwindow-1a.6 {-padx 1.3 1 badValue {bad screen distance "badValue"}} + panedwindow-1a.7 {-pady 1.3 1 badValue {bad screen distance "badValue"}} + panedwindow-1a.8 {-sticky nsew nesw abcd {bad stickyness value "abcd": must be a string containing zero or more of n, e, s, and w}} + panedwindow-1a.9 {-stretch alw always foo {bad stretch "foo": must be always, first, last, middle, or never}} + panedwindow-1a.10 {-width 10 10 badValue {bad screen distance "badValue"}} } { - set name [lindex $test 0] - test panedwindow-1.$i {configuration options} { - .p paneconfigure .b $name [lindex $test 1] - list [lindex [.p paneconfigure .b $name] 4] [.p panecget .b $name] - } [list [lindex $test 2] [lindex $test 2]] - incr i - if {[lindex $test 3] != ""} { - test panedwindow-1.$i {configuration options} { - list [catch {.p paneconfigure .b $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .p paneconfigure .b $name [lindex [.p paneconfigure .b $name] 3] - incr i + lassign $testData optionName goodIn goodOut badIn badOut + test ${testName}(good) "configuration options: $optionName" { + .p paneconfigure .b $optionName $goodIn + list [lindex [.p paneconfigure .b $optionName] 4] \ + [.p panecget .b $optionName] + } [list $goodOut $goodOut] + test ${testName}(bad) "configuration options: $optionName" -body { + .p paneconfigure .b $optionName $badIn + } -returnCodes error -result $badOut + # Reset to default + .p paneconfig .b $optionName [lindex [.p paneconfig .b $optionName] 3] } destroy .p .b .c @@ -1936,7 +1947,7 @@ test panedwindow-22.16 {ArrangePanes, last pane grows} { [winfo width .f4] [winfo width .p] } -cleanup {destroy .p .f1 .f2 .f3 .f4} - -result {50 150 1 1 222 50 150 1 78 300} + -result {50 150 1 1 211 50 150 1 89 300} } @@ -2246,6 +2257,178 @@ test panedwindow-24.28 {ConfigurePanes, restrict possible panes} { destroy .f .f.f .f.f.f .f.f.f.p .b set result } [list 0 ""] +test panedwindow-24.29.1 {ConfigurePanes, -hide works} { + -body { + panedwindow .p -showhandle false + frame .f1 -width 40 -height 100 -bg red + frame .f2 -width 40 -height 100 -bg white + frame .f3 -width 40 -height 100 -bg blue + frame .f4 -width 40 -height 100 -bg green + .p add .f1 .f2 .f3 .f4 + pack .p + update + set result [list] + lappend result [winfo ismapped .f1] [winfo ismapped .f2] \ + [winfo ismapped .f3] [winfo ismapped .f4] + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] [winfo width .p] + .p paneconfigure .f2 -hide 1 + update + lappend result [winfo ismapped .f1] [winfo ismapped .f2] \ + [winfo ismapped .f3] [winfo ismapped .f4] + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] [winfo width .p] + } + -cleanup {destroy .p .f1 .f2 .f3 .f4} + -result {1 1 1 1 40 40 40 40 171 1 0 1 1 40 40 40 40 128} +} +test panedwindow-24.29.2 {ConfigurePanes, -hide works} { + -body { + panedwindow .p -showhandle false -width 130 -height 100 + frame .f1 -width 40 -bg red + frame .f2 -width 40 -bg white + frame .f3 -width 40 -bg blue + frame .f4 -width 40 -bg green + .p add .f1 .f2 .f3 .f4 + pack .p + update + set result [list] + lappend result [winfo ismapped .f1] [winfo ismapped .f2] \ + [winfo ismapped .f3] [winfo ismapped .f4] + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] [winfo width .p] + .p paneconfigure .f2 -hide 1 + update + lappend result [winfo ismapped .f1] [winfo ismapped .f2] \ + [winfo ismapped .f3] [winfo ismapped .f4] + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] [winfo width .p] + } + -cleanup {destroy .p .f1 .f2 .f3 .f4} + -result {1 1 1 0 39 40 40 1 130 1 0 1 1 40 40 40 42 130} +} +test panedwindow-24.29.3 {ConfigurePanes, -hide works, last pane stretches} { + -body { + panedwindow .p -showhandle false -width 200 -height 200 -borderwidth 0 + frame .f1 -width 50 -bg red + frame .f2 -width 50 -bg green + frame .f3 -width 50 -bg blue + .p add .f1 .f2 .f3 + pack .p + update + set result [list] + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] + .p paneconfigure .f2 -hide 1 + update + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] + } + -cleanup {destroy .p .f1 .f2 .f3} + -result {50 50 94 50 50 147} +} +test panedwindow-24.29.4 {ConfigurePanes, -hide works, last pane stretches} { + -body { + panedwindow .p -showhandle false -width 200 -height 200 \ + -borderwidth 0 -orient vertical + frame .f1 -height 50 -bg red + frame .f2 -height 50 -bg green + frame .f3 -height 50 -bg blue + .p add .f1 .f2 .f3 + pack .p + update + set result [list] + lappend result [winfo height .f1] [winfo height .f2] [winfo height .f3] + .p paneconfigure .f2 -hide 1 + update + lappend result [winfo height .f1] [winfo height .f2] [winfo height .f3] + } + -cleanup {destroy .p .f1 .f2 .f3} + -result {50 50 94 50 50 147} +} + +test panedwindow-24.30 {ConfigurePanes, -stretch first} { + -body { + panedwindow .p -showhandle false -height 100 -width 182 + frame .f1 -width 40 -bg red + frame .f2 -width 40 -bg white + frame .f3 -width 40 -bg blue + frame .f4 -width 40 -bg green + .p add .f1 .f2 .f3 .f4 -stretch first + pack .p + update + set result [list] + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] + .p paneconfigure .f2 -hide 1 + update + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] + } + -cleanup {destroy .p .f1 .f2 .f3 .f4} + -result {51 40 40 40 94 40 40 40} +} +test panedwindow-24.31 {ConfigurePanes, -stretch middle} { + -body { + panedwindow .p -showhandle false -height 100 -width 182 + frame .f1 -width 40 -bg red + frame .f2 -width 40 -bg white + frame .f3 -width 40 -bg blue + frame .f4 -width 40 -bg green + .p add .f1 .f2 .f3 .f4 -stretch middle + pack .p + update + set result [list] + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] + .p paneconfigure .f2 -hide 1 + update + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] + } + -cleanup {destroy .p .f1 .f2 .f3 .f4} + -result {40 45 46 40 40 45 94 40} +} +test panedwindow-24.32 {ConfigurePanes, -stretch always} { + -body { + panedwindow .p -showhandle false -height 100 -width 182 + frame .f1 -width 40 -bg red + frame .f2 -width 40 -bg white + frame .f3 -width 40 -bg blue + frame .f4 -width 40 -bg green + .p add .f1 .f2 .f3 .f4 -stretch always + pack .p + update + set result [list] + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] + .p paneconfigure .f2 -hide 1 + update + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] + } + -cleanup {destroy .p .f1 .f2 .f3 .f4} + -result {42 43 43 43 58 43 58 58} +} +test panedwindow-24.33 {ConfigurePanes, -stretch never} { + -body { + panedwindow .p -showhandle false -height 100 -width 182 + frame .f1 -width 40 -bg red + frame .f2 -width 40 -bg white + frame .f3 -width 40 -bg blue + frame .f4 -width 40 -bg green + .p add .f1 .f2 .f3 .f4 -stretch never + pack .p + update + set result [list] + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] + .p paneconfigure .f2 -hide 1 + update + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ + [winfo width .f4] + } + -cleanup {destroy .p .f1 .f2 .f3 .f4} + -result {40 40 40 40 40 40 40 40} +} test panedwindow-25.1 {Unlink, remove a paned with -before/-after refs} { # Bug 928413 @@ -2587,5 +2770,5 @@ test panedwindow-30.2 {display on depths other than the default one} { } # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/place.test b/tests/place.test index 112cc78..ac2ece7 100644 --- a/tests/place.test +++ b/tests/place.test @@ -6,10 +6,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # Used for constraining memory leak tests @@ -88,6 +85,12 @@ test place-4.1 {ConfigureSlave procedure, bad -in options} { } [list 1 "can't place .t.f2 relative to itself"] test place-4.2 {ConfigureSlave procedure, bad -in option} { place forget .t.f2 + list [winfo manager .t.f2] \ + [catch {place .t.f2 -in .t.f2} err] $err \ + [winfo manager .t.f2] +} {{} 1 {can't place .t.f2 relative to itself} {}} +test place-4.3 {ConfigureSlave procedure, bad -in option} { + place forget .t.f2 list [catch {place .t.f2 -in .} msg] $msg } [list 1 "can't place .t.f2 relative to ."] @@ -422,5 +425,5 @@ test place-14.1 {memory leak testing} -setup { catch {destroy .t} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/pwrdLogo150.gif b/tests/pwrdLogo150.gif Binary files differnew file mode 100644 index 0000000..89eec7c --- /dev/null +++ b/tests/pwrdLogo150.gif diff --git a/tests/raise.test b/tests/raise.test index 33bddda..a17fa2e 100644 --- a/tests/raise.test +++ b/tests/raise.test @@ -9,14 +9,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint testmakeexist [llength [info commands testmakeexist]] - # Procedure to create a bunch of overlapping windows, which should # make it easy to detect differences in order. @@ -288,18 +283,5 @@ test raise-7.8 {errors in raise/lower commands} { deleteWindows # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/safe.test b/tests/safe.test index 10c8b29..3e9f716 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands ## NOTE: Any time tests fail here with an error like: @@ -35,16 +32,14 @@ tcltest::loadTestedCommands # The set of hidden commands is platform dependent: -if {"$tcl_platform(platform)" == "macintosh"} { - set hidden_cmds {beep bell cd clipboard echo encoding exit fconfigure file glob grab load ls menu open pwd selection send socket source tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile toplevel wm} -} elseif {"$tcl_platform(platform)" == "windows"} { - set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection socket source tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} +if {[string equal $tcl_platform(platform) "windows"]} { + set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection socket source tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile tk_messageBox toplevel unload wm} } else { - set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source toplevel wm} + set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source toplevel unload wm} } set saveAutoPath $::auto_path -set ::auto_path [list [info library] $::tk_library] +set auto_path [list [info library] $::tk_library] test safe-1.1 {Safe Tk loading into an interpreter} { catch {safe::interpDelete a} @@ -217,5 +212,5 @@ test safe-7.1 {canvas printing} { # cleanup set ::auto_path $saveAutoPath unset hidden_cmds -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/scale.test b/tests/scale.test index ae36982..657f668 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # Create entries in the option database to be sure that geometry options @@ -79,7 +76,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]] @@ -869,5 +866,5 @@ catch {destroy .s} option clear # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/scrollbar.test b/tests/scrollbar.test index c410c68..5d4334f 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -8,18 +8,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -## testmetrics is a win/mac only test command -## -testConstraint testmetrics [llength [info commands testmetrics]] - -update - proc scroll args { global scrollInfo set scrollInfo $args @@ -91,43 +82,45 @@ foreach test { {-troughcolor #432 #432 lousy {unknown color name "lousy"}} {-width 32 32 badValue {bad screen distance "badValue"}} } { - set name [lindex $test 0] - test scrollbar-1.1 {configuration options} { - .s configure $name [lindex $test 1] - lindex [.s configure $name] 4 - } [lindex $test 2] + lassign $test name value okResult badValue badResult + # Assume $name is plain; true of all our in-use options! + test scrollbar-1.$i {configuration options} \ + ".s configure $name [list $value]; .s cget $name" $okResult incr i - if {[lindex $test 3] != ""} { - test scrollbar-1.2 {configuration options} { - list [catch {.s configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + if {$badValue ne ""} { + test scrollbar-1.$i {configuration options} \ + -body [list .s configure $name $badValue] \ + -returnCodes error -result $badResult + incr i } .s configure $name [lindex [.s configure $name] 3] - incr i } destroy .s -test scrollbar-2.1 {Tk_ScrollbarCmd procedure} { - list [catch {scrollbar} msg] $msg -} {1 {wrong # args: should be "scrollbar pathName ?options?"}} -test scrollbar-2.2 {Tk_ScrollbarCmd procedure} { - list [catch {scrollbar gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test scrollbar-2.3 {Tk_ScrollbarCmd procedure} { +test scrollbar-2.1 {Tk_ScrollbarCmd procedure} -returnCodes error -body { + scrollbar +} -result {wrong # args: should be "scrollbar pathName ?options?"} +test scrollbar-2.2 {Tk_ScrollbarCmd procedure} -body { + scrollbar gorp +} -returnCodes error -result {bad window path name "gorp"} +test scrollbar-2.3 {Tk_ScrollbarCmd procedure} -setup { scrollbar .s - set x "[winfo class .s] [info command .s]" +} -body { + list [winfo class .s] [info command .s] +} -cleanup { destroy .s - set x -} {Scrollbar .s} +} -result {Scrollbar .s} test scrollbar-2.4 {Tk_ScrollbarCmd procedure} { list [catch {scrollbar .s -gorp blah} msg] $msg [winfo exists .s] \ [info command .s] } {1 {unknown option "-gorp"} 0 {}} -test scrollbar-2.5 {Tk_ScrollbarCmd procedure} { - set x [scrollbar .s] +test scrollbar-2.5 {Tk_ScrollbarCmd procedure} -setup { + catch {destroy .s} +} -body { + scrollbar .s +} -cleanup { destroy .s - set x -} {.s} +} -result .s scrollbar .s -orient vertical -command scroll -highlightthickness 2 -bd 2 pack .s -side right -fill y @@ -168,18 +161,24 @@ test scrollbar-3.10 {ScrollbarWidgetCmd procedure, "cget" option} { list [catch {.s cget -orient} msg] $msg } {0 vertical} scrollbar .s2 -test scrollbar-3.11 {ScrollbarWidgetCmd procedure, "cget" option} {pcOnly} { - list [catch {.s2 cget -bd} msg] $msg -} {0 0} -test scrollbar-3.12 {ScrollbarWidgetCmd procedure, "cget" option} {macOrUnix} { - list [catch {.s2 cget -bd} msg] $msg -} {0 2} -test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} {pcOnly} { - list [catch {.s2 cget -highlightthickness} msg] $msg -} {0 0} -test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} {macOrUnix} { - list [catch {.s2 cget -highlightthickness} msg] $msg -} {0 1} +test scrollbar-3.11 {ScrollbarWidgetCmd procedure, "cget" option} { + expr {[.s2 cget -bd] == [lindex [.s2 configure -bd] 3]} +} 1 +test scrollbar-3.12 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest { + # empty test; duplicated scrollbar-3.11 +} {} +test scrollbar-3.12.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest { + # empty test; duplicated scrollbar-3.11 +} {} +test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} { + expr {[.s2 cget -highlightthickness] == [lindex [.s2 configure -highlightthickness] 3]} +} 1 +test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest { + # empty test; duplicated scrollbar-3.13 +} {} +test scrollbar-3.14.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest { + # empty test; duplicated scrollbar-3.13 +} {} destroy .s2 test scrollbar-3.15 {ScrollbarWidgetCmd procedure, "configure" option} { llength [.s configure] @@ -215,13 +214,13 @@ test scrollbar-3.24 {ScrollbarWidgetCmd procedure, "delta" option} { list [catch {.s delta 18 xxyz} msg] $msg } {1 {expected integer but got "xxyz"}} test scrollbar-3.25 {ScrollbarWidgetCmd procedure, "delta" option} { - .s delta 20 0 + format {%.6g} [.s delta 20 0] } {0} test scrollbar-3.26 {ScrollbarWidgetCmd procedure, "delta" option} { - .s delta 0 20 + format {%.6g} [.s delta 0 20] } [format %.6g [expr 20.0/([getTroughSize .s]-1)]] test scrollbar-3.27 {ScrollbarWidgetCmd procedure, "delta" option} { - .s delta 0 -20 + format {%.6g} [.s delta 0 -20] } [format %.6g [expr -20.0/([getTroughSize .s]-1)]] test scrollbar-3.28 {ScrollbarWidgetCmd procedure, "delta" option} { toplevel .t -width 250 -height 100 @@ -229,8 +228,8 @@ test scrollbar-3.28 {ScrollbarWidgetCmd procedure, "delta" option} { scrollbar .t.s -orient horizontal -borderwidth 2 place .t.s -width 201 update - set result [list [.t.s delta 0 20] \ - [.t.s delta [expr [getTroughSize .t.s] - 1] 0]] + set result [list [format {%.6g} [.t.s delta 0 20]] \ + [format {%.6g} [.t.s delta [expr [getTroughSize .t.s] - 1] 0]]] destroy .t set result } {0 1} @@ -247,32 +246,30 @@ test scrollbar-3.32 {ScrollbarWidgetCmd procedure, "fraction" option} { list [catch {.s fraction 24 bogus} msg] $msg } {1 {expected integer but got "bogus"}} test scrollbar-3.33 {ScrollbarWidgetCmd procedure, "fraction" option} { - .s fraction 0 0 + format {%.6g} [.s fraction 0 0] } {0} test scrollbar-3.34 {ScrollbarWidgetCmd procedure, "fraction" option} { - .s fraction 0 1000 + format {%.6g} [.s fraction 0 1000] } {1} test scrollbar-3.35 {ScrollbarWidgetCmd procedure, "fraction" option} { - .s fraction 4 21 + format {%.6g} [.s fraction 4 21] } [format %.6g [expr (21.0 - ([winfo height .s] - [getTroughSize .s])/2.0) \ /([getTroughSize .s] - 1)]] -test scrollbar-3.36 {ScrollbarWidgetCmd procedure, "fraction" option} {unixOnly} { - .s fraction 4 179 +test scrollbar-3.36 {ScrollbarWidgetCmd procedure, "fraction" option} unix { + format {%.6g} [.s fraction 4 179] } {1} test scrollbar-3.37 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics} { - .s fraction 4 [expr 200 - [testmetrics cyvscroll .s]] + format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s]]] } {1} -test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} {unixOnly} { - .s fraction 4 178 +test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} unix { + format {%.6g} [.s fraction 4 178] } {0.993711} -test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics pcOnly} { - expr [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s] - 2]] \ +test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics win} { + expr \ + [format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s] - 2]]] \ == [format %g [expr (200.0 - [testmetrics cyvscroll .s]*2 - 2) \ / ($height - 1 - [testmetrics cyvscroll .s]*2)]] } 1 -test scrollbar-3.40 {ScrollbarWidgetCmd procedure, "fraction" option} {macOnly} { - .s fraction 4 178 -} {0.97006} toplevel .t -width 250 -height 100 wm geom .t +0+0 @@ -281,7 +278,7 @@ place .t.s -width 201 update test scrollbar-3.41 {ScrollbarWidgetCmd procedure, "fraction" option} { - .t.s fraction 100 0 + format {%.6g} [.t.s fraction 100 0] } {0.5} if {[testConstraint testmetrics]} { place configure .t.s -width [expr 2*[testmetrics cxhscroll .t.s]+1] @@ -290,7 +287,7 @@ if {[testConstraint testmetrics]} { } update test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} { - .t.s fraction 100 0 + format {%.6g} [.t.s fraction 100 0] } {0} destroy .t test scrollbar-3.43 {ScrollbarWidgetCmd procedure, "get" option} { @@ -336,10 +333,7 @@ test scrollbar-3.53 {ScrollbarWidgetCmd procedure, "identify" option} { test scrollbar-3.54 {ScrollbarWidgetCmd procedure, "identify" option} {unixOrPc} { .s identify 5 195 } {arrow2} -test scrollbar-3.55 {ScrollbarWidgetCmd procedure, "identify" option} {macOnly} { - .s identify 5 195 -} {} -test scrollbar-3.56 {ScrollbarWidgetCmd procedure, "identify" option} {unixOnly} { +test scrollbar-3.56 {ScrollbarWidgetCmd procedure, "identify" option} unix { .s identify 0 0 } {} test scrollbar-3.57 {ScrollbarWidgetCmd procedure, "set" option} { @@ -436,22 +430,17 @@ scrollbar .s -orient vertical -relief sunken -bd 2 -highlightthickness 2 pack .s -side left -fill y .s set .2 .4 update -test scrollbar-6.1 {ScrollbarPosition procedure} {unixOnly} { + +test scrollbar-6.1 {ScrollbarPosition procedure} unix { .s identify 8 3 } {} -test scrollbar-6.2 {ScrollbarPosition procedure} {macOnly} { - .s identify 8 3 -} {arrow1} -test scrollbar-6.3 {ScrollbarPosition procedure} {macOrUnix} { +test scrollbar-6.3 {ScrollbarPosition procedure} unix { .s identify 8 196 } {} -test scrollbar-6.4 {ScrollbarPosition procedure} {unixOnly} { +test scrollbar-6.4 {ScrollbarPosition procedure} unix { .s identify 3 100 } {} -test scrollbar-6.5 {ScrollbarPosition procedure} {macOnly} { - .s identify 3 100 -} {trough2} -test scrollbar-6.6 {ScrollbarPosition procedure} {macOrUnix} { +test scrollbar-6.6 {ScrollbarPosition procedure} unix { .s identify 19 100 } {} test scrollbar-6.7 {ScrollbarPosition procedure} { @@ -466,66 +455,56 @@ test scrollbar-6.9 {ScrollbarPosition procedure} { test scrollbar-6.10 {ScrollbarPosition procedure} { .s identify [winfo width .s] [expr [winfo height .s] / 2] } {} - -test scrollbar-6.11 {ScrollbarPosition procedure} {macOrUnix} { +test scrollbar-6.11 {ScrollbarPosition procedure} unix { .s identify 8 4 } {arrow1} -test scrollbar-6.12 {ScrollbarPosition procedure} {unixOnly} { +test scrollbar-6.12 {ScrollbarPosition procedure} unix { .s identify 8 19 } {arrow1} -test scrollbar-6.13 {ScrollbarPosition procedure} {macOnly} { - .s identify 8 19 -} {trough1} -test scrollbar-6.14 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.14 {ScrollbarPosition procedure} win { .s identify [expr [winfo width .s] / 2] 0 } {arrow1} -test scrollbar-6.15 {ScrollbarPosition procedure} {testmetrics pcOnly} { +test scrollbar-6.15 {ScrollbarPosition procedure} {testmetrics win} { .s identify [expr [winfo width .s] / 2] [expr [testmetrics cyvscroll .s] - 1] } {arrow1} - -test scrollbar-6.16 {ScrollbarPosition procedure} {macOrUnix} { +test scrollbar-6.16 {ScrollbarPosition procedure} unix { .s identify 8 20 } {trough1} -test scrollbar-6.17 {ScrollbarPosition procedure} {macOrUnix nonPortable} { +test scrollbar-6.17 {ScrollbarPosition procedure} {unix nonPortable} { # Don't know why this is non-portable, but it doesn't work on # some platforms. .s identify 8 51 } {trough1} -test scrollbar-6.18 {ScrollbarPosition procedure} {testmetrics pcOnly} { +test scrollbar-6.18 {ScrollbarPosition procedure} {testmetrics win} { .s identify [expr [winfo width .s] / 2] [testmetrics cyvscroll .s] } {trough1} -test scrollbar-6.19 {ScrollbarPosition procedure} {testmetrics pcOnly} { +test scrollbar-6.19 {ScrollbarPosition procedure} {testmetrics win} { .s identify [expr [winfo width .s] / 2] [expr int(.2 / [.s delta 0 1]) \ + [testmetrics cyvscroll .s] - 1] } {trough1} - -test scrollbar-6.20 {ScrollbarPosition procedure} {macOrUnix} { +test scrollbar-6.20 {ScrollbarPosition procedure} unix { .s identify 8 52 } {slider} -test scrollbar-6.21 {ScrollbarPosition procedure} {macOrUnix nonPortable} { +test scrollbar-6.21 {ScrollbarPosition procedure} {unix nonPortable} { # Don't know why this is non-portable, but it doesn't work on # some platforms. .s identify 8 83 } {slider} -test scrollbar-6.22 {ScrollbarPosition procedure} {testmetrics pcOnly} { +test scrollbar-6.22 {ScrollbarPosition procedure} {testmetrics win} { .s identify [expr [winfo width .s] / 2] \ [expr int(.2 / [.s delta 0 1] + 0.5) + [testmetrics cyvscroll .s]] } {slider} -test scrollbar-6.23 {ScrollbarPosition procedure} {testmetrics pcOnly} { +test scrollbar-6.23 {ScrollbarPosition procedure} {testmetrics win} { .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ - + [testmetrics cyvscroll -s] - 1] + + [testmetrics cyvscroll .s] - 1] } {slider} - -test scrollbar-6.24 {ScrollbarPosition procedure} {macOrUnix} { +test scrollbar-6.24 {ScrollbarPosition procedure} unix { .s identify 8 84 } {trough2} -test scrollbar-6.25 {ScrollbarPosition procedure} {unixOnly} { +test scrollbar-6.25 {ScrollbarPosition procedure} unix { .s identify 8 179 } {trough2} -test scrollbar-6.26 {ScrollbarPosition procedure} {macOnly} { - .s identify 8 179 -} {arrow2} -test scrollbar-6.27 {ScrollbarPosition procedure} {testmetrics pcOnly knownBug} { +test scrollbar-6.27 {ScrollbarPosition procedure} {testmetrics win knownBug} { # This asks for 8,21, which is actually the slider, but there is a # bug in that GetSystemMetrics(SM_CYVTHUMB) actually returns a value # that is larger than the thumb displayed, skewing the ability to @@ -533,41 +512,33 @@ test scrollbar-6.27 {ScrollbarPosition procedure} {testmetrics pcOnly knownBug} .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ + [testmetrics cyvscroll .s]] } {trough2} -test scrollbar-6.28 {ScrollbarPosition procedure} {testmetrics pcOnly} { +test scrollbar-6.28 {ScrollbarPosition procedure} {testmetrics win} { .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ - [testmetrics cyvscroll .s] - 1] } {trough2} - -test scrollbar-6.29 {ScrollbarPosition procedure} {macOrUnix} { +test scrollbar-6.29 {ScrollbarPosition procedure} unix { .s identify 8 180 } {arrow2} -test scrollbar-6.30 {ScrollbarPosition procedure} {unixOnly} { +test scrollbar-6.30 {ScrollbarPosition procedure} unix { .s identify 8 195 } {arrow2} -test scrollbar-6.31 {ScrollbarPosition procedure} {macOnly} { - .s identify 8 195 -} {} -test scrollbar-6.32 {ScrollbarPosition procedure} {testmetrics pcOnly} { +test scrollbar-6.32 {ScrollbarPosition procedure} {testmetrics win} { .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ - [testmetrics cyvscroll .s]] } {arrow2} -test scrollbar-6.33 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.33 {ScrollbarPosition procedure} win { .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] - 1] } {arrow2} - -test scrollbar-6.34 {ScrollbarPosition procedure} {macOrUnix} { +test scrollbar-6.34 {ScrollbarPosition procedure} unix { .s identify 4 100 } {trough2} -test scrollbar-6.35 {ScrollbarPosition procedure} {unixOnly} { +test scrollbar-6.35 {ScrollbarPosition procedure} unix { .s identify 18 100 } {trough2} -test scrollbar-6.36 {ScrollbarPosition procedure} {macOnly} { - .s identify 18 100 -} {} -test scrollbar-6.37 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.37 {ScrollbarPosition procedure} win { .s identify 0 100 } {trough2} -test scrollbar-6.38 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.38 {ScrollbarPosition procedure} win { .s identify [expr [winfo width .s] - 1] 100 } {trough2} @@ -578,29 +549,24 @@ scrollbar .t.s -orient horizontal -relief sunken -bd 2 -highlightthickness 2 place .t.s -width 200 .t.s set .2 .4 update -test scrollbar-6.39 {ScrollbarPosition procedure} {macOrUnix} { + +test scrollbar-6.39 {ScrollbarPosition procedure} unix { .t.s identify 4 8 } {arrow1} -test scrollbar-6.40 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.40 {ScrollbarPosition procedure} win { .t.s identify 0 [expr [winfo height .t.s] / 2] } {arrow1} -test scrollbar-6.41 {ScrollbarPosition procedure} {unixOnly} { +test scrollbar-6.41 {ScrollbarPosition procedure} unix { .t.s identify 82 8 } {slider} -test scrollbar-6.42 {ScrollbarPosition procedure} {macOnly} { - .t.s identify 82 8 -} {} -test scrollbar-6.43 {ScrollbarPosition procedure} {testmetrics pcOnly} { +test scrollbar-6.43 {ScrollbarPosition procedure} {testmetrics win} { .t.s identify [expr int(.4 / [.t.s delta 1 0]) + [testmetrics cxhscroll .t.s] \ - 1] [expr [winfo height .t.s] / 2] } {slider} -test scrollbar-6.44 {ScrollbarPosition procedure} {unixOnly} { +test scrollbar-6.44 {ScrollbarPosition procedure} unix { .t.s identify 100 18 } {trough2} -test scrollbar-6.45 {ScrollbarPosition procedure} {macOnly} { - .t.s identify 100 18 -} {} -test scrollbar-6.46 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.46 {ScrollbarPosition procedure} win { .t.s identify 100 [expr [winfo height .t.s] - 1] } {trough2} @@ -619,6 +585,7 @@ wm geometry .t +0+0 test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} { proc doit {args} { destroy .t.f } proc bgerror {args} {} + destroy .t.f frame .t.f scrollbar .t.f.s -command doit pack .t.f -fill both -expand 1 @@ -637,6 +604,7 @@ test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} { test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} { proc doit {args} { destroy .t.f.s } proc bgerror {args} {} + destroy .t.f frame .t.f scrollbar .t.f.s -command doit pack .t.f -fill both -expand 1 @@ -668,18 +636,5 @@ catch {destroy .s} catch {destroy .t} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/select.test b/tests/select.test index 602d88d..8cbfd39 100644 --- a/tests/select.test +++ b/tests/select.test @@ -12,13 +12,10 @@ # package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::interpreter +namespace import -force ::tk::test:loadTkCommand global longValue selValue selInfo @@ -130,13 +127,13 @@ test select-1.3 {Tk_CreateSelHandler procedure} { set selInfo "" list [selection get TEST] $selInfo } {{Test value} {TEST 0 4000}} -test select-1.4.1 {Tk_CreateSelHandler procedure} {unixOnly} { +test select-1.4.1 {Tk_CreateSelHandler procedure} unix { setup selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} lsort [selection get TARGETS] } {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} -test select-1.4.2 {Tk_CreateSelHandler procedure} {macOrPc} { +test select-1.4.2 {Tk_CreateSelHandler procedure} win { setup selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} @@ -151,7 +148,7 @@ test select-1.5 {Tk_CreateSelHandler procedure} { set selInfo "" list [selection get] $selInfo } {{} {STRING 0 4000}} -test select-1.6.1 {Tk_CreateSelHandler procedure} {unixOnly} { +test select-1.6.1 {Tk_CreateSelHandler procedure} unix { global selValue selInfo setup selection handle .f1 {handler TEST} TEST @@ -164,7 +161,7 @@ test select-1.6.1 {Tk_CreateSelHandler procedure} {unixOnly} { selection get -type TEST list [set selInfo] [lsort [selection get TARGETS]] } {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} -test select-1.6.2 {Tk_CreateSelHandler procedure} {macOrPc} { +test select-1.6.2 {Tk_CreateSelHandler procedure} win { global selValue selInfo setup selection handle .f1 {handler TEST} TEST @@ -177,21 +174,21 @@ test select-1.6.2 {Tk_CreateSelHandler procedure} {macOrPc} { selection get -type TEST list [set selInfo] [lsort [selection get TARGETS]] } {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-1.7.1 {Tk_CreateSelHandler procedure} {unixOnly} { +test select-1.7.1 {Tk_CreateSelHandler procedure} unix { setup selection own -selection CLIPBOARD .f1 selection handle -selection CLIPBOARD .f1 {handler TEST} TEST selection handle -selection PRIMARY .f1 {handler TEST2} STRING list [lsort [selection get -selection PRIMARY TARGETS]] \ - [lsort [selection get -selection CLIPBOARD TARGETS]] + [lsort [selection get -selection CLIPBOARD TARGETS]] } {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-1.7.2 {Tk_CreateSelHandler procedure} {macOrPc} { +test select-1.7.2 {Tk_CreateSelHandler procedure} win { setup selection own -selection CLIPBOARD .f1 selection handle -selection CLIPBOARD .f1 {handler TEST} TEST selection handle -selection PRIMARY .f1 {handler TEST2} STRING list [lsort [selection get -selection PRIMARY TARGETS]] \ - [lsort [selection get -selection CLIPBOARD TARGETS]] + [lsort [selection get -selection CLIPBOARD TARGETS]] } {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-1.8 {Tk_CreateSelHandler procedure} { setup @@ -201,56 +198,56 @@ test select-1.8 {Tk_CreateSelHandler procedure} { ############################################################################## -test select-2.1 {Tk_DeleteSelHandler procedure} {unixOnly} { +test select-2.1 {Tk_DeleteSelHandler procedure} unix { setup - selection handle .f1 {handler STRING} - selection handle -type TEST .f1 {handler TEST} - selection handle -type USER .f1 {handler USER} + selection handle .f1 {handler STRING} + selection handle -type TEST .f1 {handler TEST} + selection handle -type USER .f1 {handler USER} set result [list [lsort [selection get TARGETS]]] selection handle -type TEST .f1 {} lappend result [lsort [selection get TARGETS]] } {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING}} -test select-2.2 {Tk_DeleteSelHandler procedure} {unixOnly} { +test select-2.2 {Tk_DeleteSelHandler procedure} unix { setup - selection handle .f1 {handler STRING} - selection handle -type TEST .f1 {handler TEST} - selection handle -type USER .f1 {handler USER} + selection handle .f1 {handler STRING} + selection handle -type TEST .f1 {handler TEST} + selection handle -type USER .f1 {handler USER} set result [list [lsort [selection get TARGETS]]] selection handle -type USER .f1 {} lappend result [lsort [selection get TARGETS]] } {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} -test select-2.3 {Tk_DeleteSelHandler procedure} {unixOnly} { +test select-2.3 {Tk_DeleteSelHandler procedure} unix { setup selection own -selection CLIPBOARD .f1 - selection handle -selection PRIMARY .f1 {handler STRING} - selection handle -selection CLIPBOARD .f1 {handler STRING} + selection handle -selection PRIMARY .f1 {handler STRING} + selection handle -selection CLIPBOARD .f1 {handler STRING} selection handle -selection CLIPBOARD .f1 {} list [lsort [selection get TARGETS]] \ [lsort [selection get -selection CLIPBOARD TARGETS]] } {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-2.4 {Tk_DeleteSelHandler procedure} {macOrPc} { +test select-2.4 {Tk_DeleteSelHandler procedure} win { setup - selection handle .f1 {handler STRING} - selection handle -type TEST .f1 {handler TEST} - selection handle -type USER .f1 {handler USER} + selection handle .f1 {handler STRING} + selection handle -type TEST .f1 {handler TEST} + selection handle -type USER .f1 {handler USER} set result [list [lsort [selection get TARGETS]]] selection handle -type TEST .f1 {} lappend result [lsort [selection get TARGETS]] } {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER}} -test select-2.5 {Tk_DeleteSelHandler procedure} {macOrPc} { +test select-2.5 {Tk_DeleteSelHandler procedure} win { setup - selection handle .f1 {handler STRING} - selection handle -type TEST .f1 {handler TEST} - selection handle -type USER .f1 {handler USER} + selection handle .f1 {handler STRING} + selection handle -type TEST .f1 {handler TEST} + selection handle -type USER .f1 {handler USER} set result [list [lsort [selection get TARGETS]]] selection handle -type USER .f1 {} lappend result [lsort [selection get TARGETS]] } {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-2.6 {Tk_DeleteSelHandler procedure} {macOrPc} { +test select-2.6 {Tk_DeleteSelHandler procedure} win { setup selection own -selection CLIPBOARD .f1 - selection handle -selection PRIMARY .f1 {handler STRING} - selection handle -selection CLIPBOARD .f1 {handler STRING} + selection handle -selection PRIMARY .f1 {handler STRING} + selection handle -selection CLIPBOARD .f1 {handler STRING} selection handle -selection CLIPBOARD .f1 {} list [lsort [selection get TARGETS]] \ [lsort [selection get -selection CLIPBOARD TARGETS]] @@ -259,7 +256,7 @@ test select-2.7 {Tk_DeleteSelHandler procedure} { setup selection handle .f1 {handler STRING} list [selection handle .f1 {}] [selection handle .f1 {}] -} {{} {}} +} {{} {}} ############################################################################## @@ -306,7 +303,7 @@ test select-3.6 {Tk_OwnSelection procedure} { selection clear .f1 lappend result $lostSel } {owned lost2} -test select-3.7 {Tk_OwnSelection procedure} {unixOnly} { +test select-3.7 {Tk_OwnSelection procedure} unix { global lostSel setup setupbg @@ -332,7 +329,6 @@ test select-3.9 {Tk_OwnSelection procedure} { selection own -selection CLIPBOARD -command { destroy .f2 } .f1 selection own -selection CLIPBOARD .f2 } {} - # multiple display tests test select-3.10 {Tk_OwnSelection procedure} {altDisplay} { setup .f1 @@ -370,7 +366,7 @@ test select-4.3 {Tk_ClearSelection procedure} { setup list [selection clear .f1] [selection clear .f1] } {{} {}} -test select-4.4 {Tk_ClearSelection procedure} {unixOnly} { +test select-4.4 {Tk_ClearSelection procedure} unix { global lostSel setup setupbg @@ -383,7 +379,6 @@ test select-4.4 {Tk_ClearSelection procedure} {unixOnly} { cleanupbg lappend result [selection own] } {{} {}} - # multiple display tests test select-4.5 {Tk_ClearSelection procedure} {altDisplay} { global lostSel lostSel2 @@ -398,7 +393,7 @@ test select-4.5 {Tk_ClearSelection procedure} {altDisplay} { update list $lostSel $lostSel2 } {owned lost2} -test select-4.6 {Tk_ClearSelection procedure} {unixOnly altDisplay} { +test select-4.6 {Tk_ClearSelection procedure} {unix altDisplay} { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) setupbg @@ -477,7 +472,7 @@ test select-5.8 {Tk_GetSelection procedure} { selection handle .f1 {weirdHandler STRING} list [selection get] $selInfo [catch {selection get} msg] $msg } "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}" -test select-5.9 {Tk_GetSelection procedure} {unixOnly} { +test select-5.9 {Tk_GetSelection procedure} unix { setup setupbg selection handle -selection PRIMARY .f1 {handler TEST} TEST @@ -489,7 +484,7 @@ test select-5.9 {Tk_GetSelection procedure} {unixOnly} { cleanupbg lappend result $selInfo } {{Test value} {TEST 0 4000}} -test select-5.10 {Tk_GetSelection procedure} {unixOnly} { +test select-5.10 {Tk_GetSelection procedure} unix { setup setupbg selection handle -selection PRIMARY .f1 {handler TEST} TEST @@ -502,9 +497,7 @@ test select-5.10 {Tk_GetSelection procedure} {unixOnly} { cleanupbg lappend result $selInfo } {{selection owner didn't respond} {}} - # multiple display tests - test select-5.11 {Tk_GetSelection procedure} {altDisplay} { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) @@ -531,7 +524,7 @@ test select-5.12 {Tk_GetSelection procedure} {altDisplay} { lappend result [catch {selection get -displayof .f2 TEST} msg] $msg \ $selInfo } {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}} -test select-5.13 {Tk_GetSelection procedure} {unixOnly altDisplay} { +test select-5.13 {Tk_GetSelection procedure} {unix altDisplay} { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) setupbg @@ -549,7 +542,7 @@ test select-5.13 {Tk_GetSelection procedure} {unixOnly altDisplay} { cleanupbg lappend result $selInfo } {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}} -test select-5.14 {Tk_GetSelection procedure} {unixOnly altDisplay} { +test select-5.14 {Tk_GetSelection procedure} {unix altDisplay} { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) setupbg @@ -573,7 +566,6 @@ test select-5.14 {Tk_GetSelection procedure} {unixOnly altDisplay} { test select-6.1 {Tk_SelectionCmd procedure} { list [catch {selection} cmd] $cmd } {1 {wrong # args: should be "selection option ?arg arg ...?"}} - # selection clear test select-6.2 {Tk_SelectionCmd procedure} { list [catch {selection clear -selection} cmd] $cmd @@ -629,7 +621,6 @@ test select-6.11 {Tk_SelectionCmd procedure} { test select-6.12 {Tk_SelectionCmd procedure} { list [catch {selection clear foo bar} cmd] $cmd } {1 {wrong # args: should be "selection clear ?options?"}} - # selection get test select-6.13 {Tk_SelectionCmd procedure} { list [catch {selection get -selection} cmd] $cmd @@ -683,7 +674,6 @@ test select-6.21 {Tk_SelectionCmd procedure} { set selInfo "" list [selection get TEST] $selInfo } {{Test value} {TEST 0 4000}} - # selection handle # most of the handle section has been covered earlier test select-6.22 {Tk_SelectionCmd procedure} { @@ -715,7 +705,6 @@ test select-6.29 {Tk_SelectionCmd procedure} { catch { destroy .f2 } list [catch {selection handle .f2 dummy} cmd] $cmd } {1 {bad window path name ".f2"}} - # selection own test select-6.30 {Tk_SelectionCmd procedure} { list [catch {selection own -selection} cmd] $cmd @@ -758,57 +747,55 @@ test select-6.37 {Tk_SelectionCmd procedure} { test select-6.38 {Tk_SelectionCmd procedure} { list [catch {selection own foo bar baz} cmd] $cmd } {1 {wrong # args: should be "selection own ?options? ?window?"}} - test select-6.39 {Tk_SelectionCmd procedure} { list [catch {selection foo} cmd] $cmd } {1 {bad option "foo": must be clear, get, handle, or own}} ############################################################################## - # 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}} +# 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}} ############################################################################## # Check reentrancy on losing selection -test select-8.1 {TkSelEventProc procedure} {unixOnly} { +test select-8.1 {TkSelEventProc procedure} -constraints unix -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 +} -constraints unix -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} unix { setup setupbg set selValue "1024 0xffff 2048 -2 " @@ -819,9 +806,8 @@ test select-9.2 {SelCvtToX and SelCvtFromX procedures} {unixOnly} { lappend result [dobg {selection get TEST}] cleanupbg lappend result $selInfo -} {{0x400 0xffff 0x800 0xfffffffe} {TEST 0 4000}} -test select-9.3 {SelCvtToX and SelCvtFromX procedures} {unixOnly} { - global selValue selInfo +} {{0x400 0xffff 0x800 0xfffffffe } {TEST 0 4000}} +test select-9.3 {SelCvtToX and SelCvtFromX procedures} unix { setup setupbg set selValue " " @@ -832,9 +818,8 @@ test select-9.3 {SelCvtToX and SelCvtFromX procedures} {unixOnly} { lappend result [dobg {selection get TEST}] cleanupbg lappend result $selInfo -} {{} {TEST 0 4000}} -test select-9.4 {SelCvtToX and SelCvtFromX procedures} {unixOnly} { - global selValue selInfo +} {{ } {TEST 0 4000}} +test select-9.4 {SelCvtToX and SelCvtFromX procedures} unix { setup setupbg set selValue "16 foobar 32" @@ -845,7 +830,7 @@ test select-9.4 {SelCvtToX and SelCvtFromX procedures} {unixOnly} { lappend result [dobg {selection get TEST}] cleanupbg lappend result $selInfo -} {{0x10 0x0 0x20} {TEST 0 4000}} +} {{0x10 0x0 0x20 } {TEST 0 4000}} test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { setup setupbg @@ -867,14 +852,14 @@ test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { # note, we are not testing MULTIPLE style selections # most control paths have been exercised above -test select-10.1 {ConvertSelection procedure, race with selection clear} {unixOnly} { +test select-10.1 {ConvertSelection procedure, race with selection clear} unix { setup proc Ready {fd} { variable x lappend x [gets $fd] } set fd [open "|[list [interpreter] -geometry +0+0 -name tktest]" r+] - puts $fd "puts foo; flush stdout" + puts $fd "puts foo; [loadTkCommand]; flush stdout" flush $fd gets $fd fileevent $fd readable [list Ready $fd] @@ -890,10 +875,12 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} {unixOn vwait [namespace which -variable x] puts $fd {exit} flush $fd - close $fd + # Don't understand why, but the [loadTkCommand] above causes + # a "broken pipe" error when Tk was actually [load]ed in the child. + catch {close $fd} lappend x $selInfo } {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}} -test select-10.2 {ConvertSelection procedure} {unixOnly} { +test select-10.2 {ConvertSelection procedure} unix { setup setupbg set selValue [string range $longValue 0 3999] @@ -904,7 +891,7 @@ test select-10.2 {ConvertSelection procedure} {unixOnly} { cleanupbg lappend result $selInfo } [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}] -test select-10.3 {ConvertSelection procedure} {unixOnly} { +test select-10.3 {ConvertSelection procedure} unix { setup setupbg selection handle .f1 ERROR errHandler @@ -915,7 +902,7 @@ test select-10.3 {ConvertSelection procedure} {unixOnly} { } {{PRIMARY selection doesn't exist or form "ERROR" not defined}} # testing timers # This one hangs in Exceed -test select-10.4 {ConvertSelection procedure} {unixOnly noExceed} { +test select-10.4 {ConvertSelection procedure} {unix noExceed} { setup setupbg set selValue $longValue @@ -927,7 +914,7 @@ test select-10.4 {ConvertSelection procedure} {unixOnly noExceed} { cleanupbg lappend result $selInfo } {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}} -test select-10.5 {ConvertSelection procedure, reentrancy issues} {unixOnly} { +test select-10.5 {ConvertSelection procedure, reentrancy issues} unix { setup setupbg set selValue "Test value" @@ -939,7 +926,7 @@ test select-10.5 {ConvertSelection procedure, reentrancy issues} {unixOnly} { cleanupbg lappend result $selInfo } {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}} -test select-10.6 {ConvertSelection procedure, reentrancy issues} {unixOnly} { +test select-10.6 {ConvertSelection procedure, reentrancy issues} unix { proc weirdHandler {type offset count} { destroy .f1 handler $type $offset $count @@ -958,7 +945,7 @@ test select-10.6 {ConvertSelection procedure, reentrancy issues} {unixOnly} { ############################################################################## # testing reentrancy -test select-11.1 {TkSelPropProc procedure} {unixOnly} { +test select-11.1 {TkSelPropProc procedure} unix { setup setupbg set selValue $longValue @@ -975,15 +962,15 @@ test select-11.1 {TkSelPropProc procedure} {unixOnly} { ############################################################################## # Note, this assumes we are using CurrentTtime -test select-12.1 {DefaultSelection procedure} {unixOnly} { +test select-12.1 {DefaultSelection procedure} unix { setup set result [selection get -type TIMESTAMP] setupbg lappend result [dobg {selection get -type TIMESTAMP}] cleanupbg set result -} {0x0 0x0} -test select-12.2 {DefaultSelection procedure} {unixOnly} { +} {0x0 {0x0 }} +test select-12.2 {DefaultSelection procedure} unix { setup set result [lsort [list [selection get -type TARGETS]]] setupbg @@ -991,7 +978,7 @@ test select-12.2 {DefaultSelection procedure} {unixOnly} { cleanupbg set result } {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-12.3 {DefaultSelection procedure} {unixOnly} { +test select-12.3 {DefaultSelection procedure} unix { setup selection handle .f1 {handler TEST} TEST set result [list [lsort [selection get -type TARGETS]]] @@ -1000,7 +987,7 @@ test select-12.3 {DefaultSelection procedure} {unixOnly} { cleanupbg set result } {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-12.4 {DefaultSelection procedure} {unixOnly} { +test select-12.4 {DefaultSelection procedure} unix { setup set result "" lappend result [selection get -type TK_APPLICATION] @@ -1009,7 +996,7 @@ test select-12.4 {DefaultSelection procedure} {unixOnly} { cleanupbg set result } [list [winfo name .] [winfo name .]] -test select-12.5 {DefaultSelection procedure} {unixOnly} { +test select-12.5 {DefaultSelection procedure} unix { setup set result [selection get -type TK_WINDOW] setupbg @@ -1018,7 +1005,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" @@ -1028,7 +1014,7 @@ test select-12.6 {DefaultSelection procedure} { lappend result [selection get TARGETS] } {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-13.1 {SelectionSize procedure, handler deleted} {unixOnly} { +test select-13.1 {SelectionSize procedure, handler deleted} unix { proc badHandler {path type offset count} { global selValue selInfo abortCount incr abortCount -1 @@ -1057,18 +1043,5 @@ test select-13.1 {SelectionSize procedure, handler deleted} {unixOnly} { catch {rename weirdHandler {}} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/send.test b/tests/send.test index 2614427..d3fce3b 100644 --- a/tests/send.test +++ b/tests/send.test @@ -11,14 +11,10 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands testConstraint xhost [llength [auto_execok xhost]] -testConstraint testsend [llength [info commands testsend]] # Compute a script that will load Tk into a child interpreter. @@ -624,5 +620,5 @@ catch { rename newApp {} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/spinbox.test b/tests/spinbox.test index 7b7da12..0fe1c33 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -5,10 +5,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands proc scroll args { @@ -446,8 +443,8 @@ test spinbox-3.64 {SpinboxWidgetCmd procedure, "selection to" widget command} { } {1 {wrong # args: should be ".e selection to index"}} test spinbox-3.65 {SpinboxWidgetCmd procedure, "xview" widget command} { .e xview 5 - .e xview -} {0.0537634 0.268817} + format {%.6f %.6f} {*}[.e xview] +} {0.053763 0.268817} test spinbox-3.66 {SpinboxWidgetCmd procedure, "xview" widget command} { list [catch {.e xview gorp} msg] $msg } {1 {bad spinbox index "gorp"}} @@ -455,7 +452,7 @@ test spinbox-3.67 {SpinboxWidgetCmd procedure, "xview" widget command} { .e xview 0 .e icursor 10 .e xview insert - .e xview + format {%.6f %.6f} {*}[.e xview] } {0.107527 0.322581} test spinbox-3.68 {SpinboxWidgetCmd procedure, "xview" widget command} { list [catch {.e xview moveto foo bar} msg] $msg @@ -465,7 +462,7 @@ test spinbox-3.69 {SpinboxWidgetCmd procedure, "xview" widget command} { } {1 {expected floating-point number but got "foo"}} test spinbox-3.70 {SpinboxWidgetCmd procedure, "xview" widget command} { .e xview moveto 0.5 - .e xview + format {%.6f %.6f} {*}[.e xview] } {0.505376 0.72043} test spinbox-3.71 {SpinboxWidgetCmd procedure, "xview" widget command} { list [catch {.e xview scroll 24} msg] $msg @@ -476,13 +473,13 @@ test spinbox-3.72 {SpinboxWidgetCmd procedure, "xview" widget command} { test spinbox-3.73 {SpinboxWidgetCmd procedure, "xview" widget command} { .e xview moveto 0 .e xview scroll 1 pages - .e xview + format {%.6f %.6f} {*}[.e xview] } {0.193548 0.408602} test spinbox-3.74 {SpinboxWidgetCmd procedure, "xview" widget command} { .e xview moveto .9 update .e xview scroll -2 p - .e xview + format {%.6f %.6f} {*}[.e xview] } {0.397849 0.612903} test spinbox-3.75 {SpinboxWidgetCmd procedure, "xview" widget command} { .e xview 30 @@ -520,12 +517,12 @@ test spinbox-3.81 {SpinboxWidgetCmd procedure, "xview" widget command} { set x {} .e xview moveto .1 - lappend x [lindex [.e xview] 0] + lappend x [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .11 - lappend x [lindex [.e xview] 0] + lappend x [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .12 - lappend x [lindex [.e xview] 0] -} {0.0957447 0.106383 0.117021} + lappend x [format {%.6f} [lindex [.e xview] 0]] +} {0.095745 0.106383 0.117021} test spinbox-3.82 {SpinboxWidgetCmd procedure} { list [catch {.e gorp} msg] $msg } {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview}} @@ -604,8 +601,8 @@ test spinbox-5.7 {ConfigureSpinbox procedure} { .e insert end "01234567890" update .e configure -width 5 - set scrollInfo -} {0 0.363636} + format {%.6f %.6f} {*}$scrollInfo +} {0.000000 0.363636} test spinbox-5.8 {ConfigureSpinbox procedure} {fonts} { catch {destroy .e} spinbox .e -width 0 @@ -729,15 +726,15 @@ test spinbox-7.1 {InsertChars procedure} { .e insert 0 abcde .e insert 2 XXX update - list [.e get] $contents $scrollInfo -} {abXXXcde abXXXcde {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {abXXXcde abXXXcde {0.000000 1.000000}} test spinbox-7.2 {InsertChars procedure} { .e delete 0 end .e insert 0 abcde .e insert 500 XXX update - list [.e get] $contents $scrollInfo -} {abcdeXXX abcdeXXX {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {abcdeXXX abcdeXXX {0.000000 1.000000}} test spinbox-7.3 {InsertChars procedure} { .e delete 0 end .e insert 0 0123456789 @@ -823,22 +820,22 @@ test spinbox-8.1 {DeleteChars procedure} { .e insert 0 abcde .e delete 2 4 update - list [.e get] $contents $scrollInfo -} {abe abe {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {abe abe {0.000000 1.000000}} test spinbox-8.2 {DeleteChars procedure} { .e delete 0 end .e insert 0 abcde .e delete -2 2 update - list [.e get] $contents $scrollInfo -} {cde cde {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {cde cde {0.000000 1.000000}} test spinbox-8.3 {DeleteChars procedure} { .e delete 0 end .e insert 0 abcde .e delete 3 1000 update - list [.e get] $contents $scrollInfo -} {abc abc {0 1}} + list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] +} {abc abc {0.000000 1.000000}} test spinbox-8.4 {DeleteChars procedure} { .e delete 0 end .e insert 0 0123456789abcde @@ -1134,26 +1131,26 @@ test spinbox-13.9 {GetSpinboxIndex procedure} { list [.e index sel.first] [.e index sel.last] } {1 6} selection clear .e -test spinbox-13.10 {GetSpinboxIndex procedure} {unixOnly} { +test spinbox-13.10 {GetSpinboxIndex procedure} unix { # On unix, when selection is cleared, spinbox widget's internal # selection range is reset. list [catch {.e index sel.first} msg] $msg } {1 {selection isn't in widget .e}} -test spinbox-13.11 {GetSpinboxIndex procedure} {macOrPc} { +test spinbox-13.11 {GetSpinboxIndex procedure} win { # On mac and pc, when selection is cleared, spinbox widget remembers # last selected range. When selection ownership is restored to # spinbox, the old range will be rehighlighted. list [catch {selection get}] [.e index sel.first] } {1 1} -test spinbox-13.12 {GetSpinboxIndex procedure} {unixOnly} { +test spinbox-13.12 {GetSpinboxIndex procedure} unix { list [catch {.e index sbogus} msg] $msg } {1 {selection isn't in widget .e}} -test spinbox-13.13 {GetSpinboxIndex procedure} {macOrPc} { +test spinbox-13.13 {GetSpinboxIndex procedure} win { list [catch {.e index sbogus} msg] $msg } {1 {bad spinbox index "sbogus"}} -test spinbox-13.14 {GetSpinboxIndex procedure} {macOrPc} { +test spinbox-13.14 {GetSpinboxIndex procedure} win { list [catch {selection get}] [catch {.e index sbogus}] } {1 1} test spinbox-13.15 {GetSpinboxIndex procedure} { @@ -1237,12 +1234,12 @@ update test spinbox-16.1 {SpinboxVisibleRange procedure} {fonts} { .e delete 0 end .e insert 0 ............................. - .e xview -} {0 0.827586} -test spinbox-15.4 {SpinboxVisibleRange procedure} { + format {%.6f %.6f} {*}[.e xview] +} {0.000000 0.827586} +test spinbox-16.2 {SpinboxVisibleRange procedure} { .e delete 0 end - .e xview -} {0 1} + format {%.6f %.6f} {*}[.e xview] +} {0.000000 1.000000} catch {destroy .e} spinbox .e -width 10 -xscrollcommand scroll -font $fixed @@ -1252,21 +1249,21 @@ test spinbox-17.1 {SpinboxUpdateScrollbar procedure} { .e delete 0 end .e insert 0 123 update - set scrollInfo -} {0 1} + format {%.6f %.6f} {*}$scrollInfo +} {0.000000 1.000000} test spinbox-17.2 {SpinboxUpdateScrollbar procedure} { .e delete 0 end .e insert 0 0123456789abcdef .e xview 3 update - set scrollInfo -} {0.1875 0.8125} + format {%.6f %.6f} {*}$scrollInfo +} {0.187500 0.812500} test spinbox-17.3 {SpinboxUpdateScrollbar procedure} { .e delete 0 end .e insert 0 abcdefghijklmnopqrs .e xview 6 update - set scrollInfo + format {%.6f %.6f} {*}$scrollInfo } {0.315789 0.842105} test spinbox-17.4 {SpinboxUpdateScrollbar procedure} { destroy .e @@ -1282,7 +1279,7 @@ test spinbox-17.4 {SpinboxUpdateScrollbar procedure} { list $x $errorInfo } {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand" while executing -"thisisnotacommand 0 1" +"thisisnotacommand 0.0 1.0" (horizontal scrolling command executed by .e)}} set l [interp hidden] @@ -1598,5 +1595,5 @@ catch {unset ::e ::vVals} option clear # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/teapot.ppm b/tests/teapot.ppm new file mode 100644 index 0000000..b8ab85f --- /dev/null +++ b/tests/teapot.ppm @@ -0,0 +1,31 @@ +P6 +256 256 +255 +\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À[7 eOLjQLmSMoTMnSMlRMhPL_9 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀnSMtVMzYN~[N~[N\N\O€\O€]O€]O€]O€]O€\O€\O}[NyYNtVM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG- wXN}[N€]O„^O†_O†`O‡`Oˆ`Oˆ`OˆaO‰aO‰aO‰aO‰aO‰aO‰aOˆaOˆ`O†_Oƒ^O\N \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀaMLyYN…_O‰aP‹bPcPŽcPŽdPŽdPdPdPdPdPdPdPdPeP‘eP’eP’eP‘ePdPcP…_OpUM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀwXN…_OdP“fP•gQ–hQ˜hQ˜iQ™iQ™iQšiQšiQšjQ›jQ›jQœjQœjQœjQœjQœjQ›jQœjQ™iQ“fP‡`O\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJiQL‹bP—hQkQ¡mR¤nR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¦pR¨pS©qSªqS«rS¬rS«rS©qS¤oRœjQ€]O\KK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀfOLrUMcPŸlR©qS¯tS²uTµwT·xT¸xT¹yTºyT»zT»zU¼zU¼zU¼zU»zUºyT¸xT¶wT¯tS¡mR‰aOhPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\Àa0 cNLqUM€\O”fQ¦pS²wVºzV¿|VÂ}VÄVÆVÇ€VÉ‚WÌ…[Õeæ w÷³‹êª…Ĉg§qT“fQ{ZNYIK9 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀO1 {G#‘JkRMqUMtVN–iS¨v\·€d¹bµzZ±vU°uT®sSªqS¤nRœjQ’eP„^OrUMHh>!T4 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG- V5 wE"~I#†M%U+¥e7²l:°g2®b*a(`(©^(¥])¡^-›]1ŠS,qC$`9 R3 G- \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À@) J/ i>!pA"tD"wF$yH&xH&tE$wE#yG%}M+ƒT4S5mE*Z7!K/ B* ;' \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À‰aO¦oR½{UÇ€VÏ…X<( F- a: e<!h>!j@#k@$h>"d<!c=$hD-fF2[<)K0 @) ;' 5$ Ë‚VÇ€V¿|U_LKYIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À…_O·xTÉ‚Wó«€ûµ‹Ö’k¼|X×>µf-¨^(¡Z'šW&–T&œN>) F- J/ b; g>#nD(jB&c<!b=%jH2_A/I0!<( 8& 5$ ”J¥Y ’S%8& ;' ?) E, <:HA=HE?IJAISFJYIKXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À£nRÁ}UܘqÊŠe±vU²e,™V&¥V†C
€@ |> y< u: r9 o7 l6 +j5 +h4 +g3 +5$ D, K/ b; h>"wM1tK.e="a<#cA,U8&E- <( 9& .!a0 b1 c1 + ++ 3# @) 46G<:HMCIXHK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀU*´vT¿~X¸{YÃk+›W&‰N$|> u: p8 k5 +f3 +a0 _/ ]. [- I¡\*ª_(‘LkRMmSMmSMnSMnSMD, R3 W5 mA"|O0|P1j?"c<!a=%Y7"N1 F, ;' NCJNCJNDJODJODJODJh>!a: X/K% +g3 +a0 Z- \/ T*Q(ŠHµm8kRMmSMnTMoTMpTMpUM15G15G05G04G04GpUMpTM5^9 d<!yF#O+€N,rC#qB"pB#k?"a: Z7 6ODJPDJPEJQEJQEJREJREJREJRFJSFJSFJSFJSFJe<!X/ +^/ V+Q(L&I$r9 TlRMnSM46G47G47G46G46G46G46G46G36G36G25G25G15G04G/4F.3F + +X&pUMuWMwXNxXN<:H<:H<:H<:H<;H<;H<;H<;H=;H=;H=;H=;H>;H>;H?<H@<HA=HC>HG@ILBIREJ[JKcNLjQL§pR±uTºzUÃ~VÈWË‚XÖŽcäsÒŽe¼{V²vT¨pSžkR•gQŒbP†_O‚^O]O€\O€\O€\O€\O€]O]O]O]O]O]O]O]O]O]O]O€\O€\O~\N}[N|ZNxXN•T%H$ +›W&rVMvWNyYNzYN|ZN}[N}[N><H?<H?<H?<H?<H?<H@<H@<H@<HA=HA=HB=HC>HE?IG@IIAIKBIODJSFJWHK—hQŸlR§pR°b(¾i*Én+Ù|7Û|6Ïr,Íq+Êp-Ãl+»g)±b(®sS§pS lRšiQ•gQePcPŠaPˆaO‡`O‡`O†_O†_O…_O…_O…_O…_O…_O…_O…_O„_O„^O„^Oƒ^Oƒ^O‚]O]O€\O~[N{ZN•T% + + +@%<-$G?@…pfdNLuWM\NdNL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀTFJvWN‰aP./01„E}[N]O…_Oˆ`O‰aP‹bPŒbPcPcPŽcPdPdPdPeP‘eP’eP’eP“fP“fQ”fQ•gQ•gQ–gQ–hQ—hQ˜hQ™iQšiQ›jQœjQkQkRžlRŸlRžY&¤\'¨^'µ^½bÀcÃe Çi Äg Àc½b¼a¹`µ^´]¯X¢[' Z'žY&¢mR¡mR¡mR lRŸlRŸlRžkRkQœkQœjQ›jQšjQšiQ™iQ™iQ˜iQ˜hQ—hQ—hQ—hQ–gQ–gQ•gQ•gQ•gQ”fQ”fQ“fQ“fP’eP‘ePdPcP‰aP—O + B\À\À\À\À\À\À\À\À\À\À%7!!C*F#P) {dYœze»p€\OgPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ`LKvWNŠaPm6 + +$ 5 ¬`(¶e)£nRœjQƒ^OJAI\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀXIK^KKdNLhPLuWM‚]OŒbP”fQeP
m6 +†`OŽcP“fQ—hQ˜hQ™iQšiQšjQ›jQ›jQ›jQœjQœjQœjQœkQkQkQkRžkRžkRžkRžlRŸlRŸlRŸlR lR lR lR¡mR¡mR¡mR¡mRºg)³c(²c(±b(V¿cÂe Åi!Åi!Àd ¼bº`¹`·_·_¶^¢Q§]'ª_(`(¹f)£nR£nR£nR£nR£nR£nR£nR¢nR¢nR¢nR¢nR¢nR¢nR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢nR¢mR¢mR£nR¢mR¢mR¡mR mRkR—hQˆGa0 ŠbP mRœjQ“fQ‰aP}[NrUMmSM…L$\À\À\À\À\À\À\À\À B B
#C, 8& H. Z7 §pR›jQ{ZN\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀQEJ[JK`LKdNLhQLqUM{ZN…_OŽcP–gQ—hQ +‹bP‘eP–hQšiQ›jQœjQkQkQkRžkRžkRžlRžlRŸlRŸlRŸlRŸlRŸlR lR lR lR mR¡mR¡mR¡mR¡mR¡mR¢mR¢mR¢mR¢nR£nRÀj*ºg)·e)¶d)Âd°XÅg Åh Âe ¿c½b½b¾bªU`(®a(¯a(³c(¾i*¤oR¤oR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤oR¤oR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¥oR¥oR¤nR¡mR›jQŽQ%Z- œjQ£nRŸlR—hQŽdP…_OuWMpTMnSMkRLa: \À\À\À\À\À\À\À B B&D 2
@* S6#G@IPDJ˜hQmSM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ]KKbMLeOLiQLlRMvWN\OˆaO‘eP—hQœjQ•gQ +!C +E'0F.4F7% 8% U/lG.SFJZIK]KKZIKB=H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀREJZJK`LKdNLgPLjQLlRMnSMpTMqUMtWMxXN{ZN~[N]O„^O†`O‰aO‹bPdP•gQ™iQœkQ lR¤nR§pSªrSsS¯tT²uT´vT¶wT·xT¹yT¹yTºyTºyT¹yT¶xT´vT¬rS¢nR—hQ¿|U¿|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ}UÀ}UÁ}UÁ}UÁ}UÁ}UÂ}UÂ~UÃ~UÃ~VÃ~VÄVÅ€WÆX®a(ŸlRªrS´vT¸yT¼zU¾|UÁ~VÃXÆ‚[Ɇ_΋dÓ‘jÔ“mÔ“nБlÊŒhĆd½_¶{[°vWªsU¦pS¢nRžkRšiQ˜hQ•gQ“fQ‘ePdPŒbP‰aO†_Oƒ^O€\O|ZNxXNsVMpTMnTMmSMjQL€C B)D&/F-3F47G6% >" Y7 kA$YIK]KK^KKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ\KKbMLeOLhPLkRLmSMnTMpTMrUMuWNyYN|ZN\N‚]O„_O‡`OŠaPŒbPŽcPeP“fP—hQ›jQžlR¢nR¥oS©qT¬sT¯uU²vU´wV¶xV¸yV¹yUºzU»zU¼{U½{U¾{U¾|U¿|U¿|U¿|U¿|U¾{U½{U¼{U¼zU»zTºyT¹yT¸xTµwT³vT´vT´vT´vT´wT´wTµwT·xT¹yTºzT¼zU½{U¾{U¿|UÀ|UÂ}UÄVÅ€WÇ‚YÉ„\͈_ÑŒdÙ”láuç£|쩂ſtî‡ëª…æ¦ÞŸ{Õ—sËŽl†d¹^³yZuW¨qU¤oSŸlRžkRœjQšiQ˜hQ–gQ”fQ‘ePdPcPŠaP‡`O„^O]O}[NyYNuWMpTMoTMmSMkRLgPL&D#.E,3F46G;' <( D"iB(VGJ]KK`LK[JKB>H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRMmSMoTMqUMsVMvXNzYN}[N€\O‚^O…_Oˆ`OŠaPŒcPdP‘eP“fQ•gQ—hQ™iQkR mS¤oT¨rU¬tW°wY´zZ¸}\»]¾€^À^Á‚^‚^Â\Á€ZÁYÁXÁ~WÁ~WÂ~VÂ~VÂ~VÃ~VÃ~UÃ~UÄ~UÄ~UÄUÄUÅVÅVÅVÅVÆVÆ€VÆ€VÇ€WÇWÈ‚XɃZË…[͇^ЊaÓdØ’iÜ—nâtè£zî©ó¯‡ø´û¸‘üº“û¹“÷¶ñ±Œé©…à¡~Ö˜vËmÇf»€`´z[®vX©rU¥pT£oS¢nS lRžkRœkRšjQ˜iQ–hQ”fQ’ePdPcP‹bPˆ`O…_O‚]O~[NzYNvWNpTMoTMnSMkRMhQLo7 ,2F36G99HC+ @ ]8 nA"\JK`ML_LKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMpTMqUMtVMwXNzZN}[N€]Oƒ^O†_OˆaO‹bPcPdP‘eP“fQ•gQ—hQ™iQ›jRžlR mS£oU§rW¬vZ²{]¹€a¿…fÅŠjËnГqÓ•sÕ–sÕ–rÕ–qÕ”oÓ’mÑjÏgÍŠcˈaɆ^È„\Ç‚[ÆYÅ€XÅ€WÅWÅWÅVÅVÅWÅ€WÆ€WÇXÈ‚YɃ[Ê…\͇_ÏŠaÒeÕ‘hÙ•mÝ™qávä¡zç¤}ê§€ë©ƒëª„é¨ƒå¥€ß |Ù›wÓ•rÌmƉh¿„c¸~^²yZ®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRœkR›jQ™iQ—hQ•gQ“fPePŽcP‹bPˆaO…_O‚^O\N{ZNwXNsVMoTMnSMlRMiQL~I#26G99G?<HA* E$ i@$ZIKaMLbML[JK;:H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀWHJ]KKbMLeOLhPLjRLlSMnTMpTMrUMuWMxXN{ZN~\N]O„^O†`O‰aO‹bPŽcPdP’eP”fQ–gQ˜hQšiQœkRžlS mT£oU¦rWªuZ¯y]´~aºƒfŠlË’sÔšzÜ¡€ã§†è«‰ë®‹í¯Œí®‹ë¬ˆè¨„ã£~ßžyÚ™tÖ•oÒjÎŒfˈbÈ…_ƃ\ÅZÄ€YÃXÂWÂ~WÂ~WÂ~WÃXÀXÄ€YÅZƃ\Ç…^Ɇ`ˈbÌŠdÍ‹fÎgÎŽiÎŽjÎŽjÍŽjËŒiljgÆd¿ƒaº^¸}]¶|\´{[²yZ°xY®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRkR›jQ™iQ—hQ•gQ“fP‘ePŽdPŒbP‰aO†_Oƒ^O€\O|ZNxXNtVMpTMnSMmSMjQLgPL99G?<HG- E&b;!YIK`MLdOM`LKNCJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀŸlRºyTÄ~UÊ‚XʃYÄXº{WtUšW'¢[(—hQ lRcP€\OhQL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRLmSMoTMqUMrVMvWNyYN|ZN\N‚]O„_O‡`O‰aPŒbPŽcPdP’fP”gQ–hQ˜iQšjRœkRžlS¡nT¤pU§sW«vZ°z]µb»„gŠlÉ‘sИyØžÞ¤…ã©Šèì±ï³‘ﳑëŠç©…⣀ݞzؘtÒ“nÎiɉdÆ…`Â]Á€[¿~Y¾}X½|W½|V¼{V¼{V¼{V¼{V¼{V¼|W¼|W½}X½}Y½~Z½~Z¼~Z»}[º}[º}[º~\º~\º~]º~]¹~]¸~]·}]¶|\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS mRŸlRkR›jQšiQ˜hQ–gQ“fQ‘ePdPŒcPŠaP‡`O„^O]O}[NyYNuWNpTMnTMmSMkRLhPL|H$D>IQ2 P+XHK_LLfQOcNLXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À©qSºyTÃ~VΈ`遲ޜv¾€]ªqS–LŽG|> g3 +S)? *%.—hQ—hQ‘eP‡`OuWM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMoTMqUMsVMwXNzYN}[N€\O‚^O…_O‡`OŠaPŒbPŽdP‘eP“fP•gQ—hQ˜iQšjRœkRŸlS¡nT¤pV§sX«vZ°z^¶b¼…gËmÊ’sјzØŸ€Þ¤…ã©Šèê¯ë°ê¯Žè¬‹å¨‡à¤‚Ûž|Ö™wÑ“qÌŽlljgÃ…bÀ‚_½\»}Zº{X¹zW¸yV·yU·xU·xU·xT·xT·xU·xU·xU·yV·yV·yW¸zW¸{X¹{Y¹|Zº}[º}[º}\º~\¹~]¹~]¸}]·|\µ{\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS¡mRŸlRkRœjQšiQ˜hQ–gQ”fQ’ePdPcPŠbP‡`O…_O‚]O~[NzZNvWNrUMoTMmSMlRMiQLeOLJAIJ(h>!]KKfQOgQN_LKD>I\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À™iQ°tS¸yT¼{UÂYÎŒeïˆô´Õ—u¶|\ Z'™LˆD
|> + +
& 3#.$ -% .% .& /&!,# ,# @70A71XNHXNHWNHWNHZRLYQLYQLXQLWQLWPLUOLSNLQMKOLJMJJ0//.-.,,-&(+ "( !' + % ' %$#" ! !$
diff --git a/tests/text.test b/tests/text.test index bf70658..17fcf29 100644 --- a/tests/text.test +++ b/tests/text.test @@ -7,11 +7,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -54,6 +52,7 @@ foreach test { {-background #ff00ff #ff00ff <gorp>} {-bd 4 4 foo} {-bg blue blue #xx} + {-blockcursor 0 0 xx} {-borderwidth 7 7 ++} {-cursor watch watch lousy} {-exportselection no 0 maybe} @@ -64,6 +63,7 @@ foreach test { {-highlightbackground #123 #123 bogus} {-highlightcolor #234 #234 bogus} {-highlightthickness -2 0 bad} + {-inactiveselectbackground #ffff01234567 #ffff01234567 bogus} {-insertbackground green green <bogus>} {-insertborderwidth 45 45 bogus} {-insertofftime 100 100 2.4} @@ -84,6 +84,7 @@ foreach test { {-spacing3 -10 0 bogus} {-state d disabled foo} {-tabs {1i 2i 3i 4i} {1i 2i 3i 4i} bad_tabs} + {-tabstyle wordprocessor wordprocessor garbage} {-undo 1 1 eh} {-width 73 73 2.4} {-wrap w word bad_wrap} @@ -113,7 +114,7 @@ test text-1.[incr i] {text options} { lappend result [lindex $i 4] } set result -} {1 blue {} {} 7 watch 0 {} fixed #012 5 #123 #234 0 green 45 100 47 2 5 3 82 raised #ffff01234567 21 yellow 0 0 0 0 disabled {1i 2i 3i 4i} {any old thing} 1 73 word {x scroll command} {test command}} +} {1 blue {} {} 0 7 watch {} 0 {} fixed #012 5 #123 #234 0 #ffff01234567 green 45 100 47 2 5 3 82 raised #ffff01234567 21 yellow 0 0 0 0 {} disabled {1i 2i 3i 4i} wordprocessor {any old thing} 1 73 word {x scroll command} {test command}} test text-2.1 {Tk_TextCmd procedure} { list [catch {text} msg] $msg @@ -130,10 +131,10 @@ test text-2.4 {Tk_TextCmd procedure} { list [catch {text .t2 -bd 2 -fg red} msg] $msg \ [lindex [.t2 config -bd] 4] [lindex [.t2 config -fg] 4] } {0 .t2 2 red} -if {$tcl_platform(platform) == "macintosh"} { - set relief solid -} elseif {$tcl_platform(platform) == "windows"} { +if {$tcl_platform(platform) == "windows"} { set relief flat +} elseif {[tk windowingsystem] eq "aqua"} { + set relief solid } else { set relief raised } @@ -152,7 +153,7 @@ test text-3.1 {TextWidgetCmd procedure, basics} { } {1 {wrong # args: should be ".t option ?arg arg ...?"}} test text-3.2 {TextWidgetCmd procedure} { list [catch {.t gorp 1.0 z 1.2} msg] $msg -} {1 {bad option "gorp": must be bbox, cget, compare, configure, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} +} {1 {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}} test text-4.1 {TextWidgetCmd procedure, "bbox" option} { list [catch {.t bbox} msg] $msg @@ -220,7 +221,7 @@ test text-6.13 {TextWidgetCmd procedure, "compare" option} { } {1 {bad comparison operator "z": must be <, <=, ==, >=, >, or !=}} test text-6.14 {TextWidgetCmd procedure, "compare" option} { list [catch {.t co 1.0 z 1.2} msg] $msg -} {1 {bad option "co": must be bbox, cget, compare, configure, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} +} {1 {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}} # "configure" option is already covered above @@ -229,7 +230,7 @@ test text-7.1 {TextWidgetCmd procedure, "debug" option} { } {1 {wrong # args: should be ".t debug boolean"}} test text-7.2 {TextWidgetCmd procedure, "debug" option} { list [catch {.t de 0 1} msg] $msg -} {1 {bad option "de": must be bbox, cget, compare, configure, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} +} {1 {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}} test text-7.3 {TextWidgetCmd procedure, "debug" option} { .t debug true .t deb @@ -322,12 +323,119 @@ test text-8.16 {TextWidgetCmd procedure, "delete" option} { .t delete 2.0 2.6 2.2 2.4 .t get 1.0 end-1c } foo\nghijklm +.t delete 1.0 end; .t insert 1.0 $prevtext +test text-8.17 {TextWidgetCmd procedure, "replace" option} { + list [catch {.t replace 1.3 2.3} err] $err +} {1 {wrong # args: should be ".t replace index1 index2 chars ?tagList chars tagList ...?"}} +test text-8.18 {TextWidgetCmd procedure, "replace" option} { + list [catch {.t replace 3.1 2.3 foo} err] $err +} {1 {Index "2.3" before "3.1" in the text}} +test text-8.19 {TextWidgetCmd procedure, "replace" option} { + list [catch {.t replace 2.1 2.3 foo} err] $err +} {0 {}} +.t delete 1.0 end; .t insert 1.0 $prevtext +test text-8.20 {TextWidgetCmd procedure, "replace" option with undo} { + .t configure -undo 0 + .t configure -undo 1 + # Ensure it is treated as a single undo action + .t replace 2.1 2.3 foo + .t edit undo + .t configure -undo 0 + string equal [.t get 1.0 end-1c] $prevtext +} {1} +test text-8.21 {TextWidgetCmd procedure, "replace" option with undo} { + .t configure -undo 0 + .t configure -undo 1 + .t replace 2.1 2.3 foo + # Ensure we can override a text widget and intercept undo + # actions. If in the future a different mechanism is available + # to do this, then we should be able to change this test. The + # behaviour tested for here is not, strictly speaking, documented. + rename .t test.t + set res {} + proc .t {args} { lappend ::res $args ; uplevel 1 test.t $args } + .t edit undo + rename .t {} + rename test.t .t + .t configure -undo 0 + set res +} {{edit undo} {delete 2.1 2.4} {mark set insert 2.1} {see insert} {insert 2.1 ef} {mark set insert 2.3} {see insert}} +test text-8.22 {TextWidgetCmd procedure, "replace" option with undo} { + .t configure -undo 0 + .t configure -undo 1 + # Ensure that undo (even composite undo like 'replace') + # works when the widget shows nothing useful. + .t replace 2.1 2.3 foo + .t configure -start 1 -end 1 + .t edit undo + .t configure -start {} -end {} + .t configure -undo 0 + if {![string equal [.t get 1.0 end-1c] $prevtext]} { + set res [list [.t get 1.0 end-1c] ne $prevtext] + } else { + set res 1 + } +} {1} +.t delete 1.0 end; .t insert 1.0 $prevtext +test text-8.23 {TextWidgetCmd procedure, "replace" option with peers, undo} { + .t configure -undo 0 + .t configure -undo 1 + .t peer create .tt -undo 1 + # Ensure that undo (even composite undo like 'replace') + # works when the the event took place in one peer, which + # is then deleted, before the undo takes place in another peer. + .tt replace 2.1 2.3 foo + .tt configure -start 1 -end 1 + destroy .tt + .t edit undo + .t configure -start {} -end {} + .t configure -undo 0 + if {![string equal [.t get 1.0 end-1c] $prevtext]} { + set res [list [.t get 1.0 end-1c] ne $prevtext] + } else { + set res 1 + } +} {1} +.t delete 1.0 end; .t insert 1.0 $prevtext +test text-8.24 {TextWidgetCmd procedure, "replace" option with peers, undo} { + .t configure -undo 0 + .t configure -undo 1 + .t peer create .tt -undo 1 + # Ensure that undo (even composite undo like 'replace') + # works when the the event took place in one peer, which + # is then deleted, before the undo takes place in another peer + # which isn't showing everything. + .tt replace 2.1 2.3 foo + set res [.tt get 2.1 2.4] + .tt configure -start 1 -end 1 + destroy .tt + .t configure -start 3 -end 4 + # msg will actually be set to a silently ignored error message here, + # (that the .tt command doesn't exist), but that is not important. + lappend res [catch {.t edit undo} msg] + .t configure -undo 0 + .t configure -start {} -end {} + if {![string equal [.t get 1.0 end-1c] $prevtext]} { + lappend res [list [.t get 1.0 end-1c] ne $prevtext] + } else { + lappend res 1 + } +} {foo 0 1} +test text-8.25 {TextWidgetCmd procedure, "replace" option crash} -setup { + destroy .tt +} -body { + text .tt + .tt insert 0.0 foo\n + .tt replace end-1l end bar +} -cleanup { + destroy .tt +} -result {} .t delete 1.0 end; .t insert 1.0 $prevtext test text-9.1 {TextWidgetCmd procedure, "get" option} { list [catch {.t get} msg] $msg -} {1 {wrong # args: should be ".t get index1 ?index2 ...?"}} +} {1 {wrong # args: should be ".t get ?-displaychars? ?--? index1 ?index2 ...?"}} test text-9.2 {TextWidgetCmd procedure, "get" option} { list [catch {.t get a b c} msg] $msg } {1 {bad text index "a"}} @@ -377,9 +485,341 @@ test text-9.15 {TextWidgetCmd procedure, "get" option} { .t get 5.2 5.4 5.4 5.5 end-3c end } {{y } G { 7 }} +test text-9.16 {TextWidgetCmd procedure, "get" option} { + .t get 5.2 5.3 5.4 5.3 +} {y} test text-9.17 {TextWidgetCmd procedure, "get" option} { + .t index "5.2 +3 indices" +} {5.5} +test text-9.17a {TextWidgetCmd procedure, "get" option} { + .t index "5.2 +3chars" +} {5.5} +test text-9.17b {TextWidgetCmd procedure, "get" option} { + .t index "5.2 +3displayindices" +} {5.5} +.t tag configure elide -elide 1 +.t tag add elide 5.2 5.4 +test text-9.18 {TextWidgetCmd procedure, "get" option} { list [catch {.t get 5.2 5.4 5.5 foo} msg] $msg } {1 {bad text index "foo"}} +test text-9.19 {TextWidgetCmd procedure, "get" option} { + .t get 5.2 5.4 5.4 5.5 end-3c end +} {{y } G { 7 +}} +test text-9.20 {TextWidgetCmd procedure, "get" option} { + .t get -displaychars 5.2 5.4 5.4 5.5 end-3c end +} {{} G { 7 +}} +test text-9.21 {TextWidgetCmd procedure, "get" option} { + list [.t index "5.1 +4indices"] [.t index "5.1+4d indices"] +} {5.5 5.7} +test text-9.22 {TextWidgetCmd procedure, "get" option} { + list [.t index "5.1 +4a chars"] [.t index "5.1+4d chars"] +} {5.5 5.7} +test text-9.23 {TextWidgetCmd procedure, "get" option} { + list [.t index "5.5 -4indices"] [.t index "5.7-4d indices"] +} {5.1 5.1} +test text-9.24 {TextWidgetCmd procedure, "get" option} { + list [.t index "5.5 -4a chars"] [.t index "5.7-4d chars"] +} {5.1 5.1} +.t window create 5.4 +test text-9.25 {TextWidgetCmd procedure, "get" option} { + list [.t index "5.1 +4indices"] [.t index "5.1+4d indices"] +} {5.5 5.7} +test text-9.25a {TextWidgetCmd procedure, "get" option} { + list [.t index "5.1 +4a chars"] [.t index "5.1+4d chars"] +} {5.6 5.8} +test text-9.26 {TextWidgetCmd procedure, "get" option} { + list [.t index "5.5 -4indices"] [.t index "5.7-4d indices"] +} {5.1 5.1} +test text-9.26a {TextWidgetCmd procedure, "get" option} { + list [.t index "5.6 -4a chars"] [.t index "5.8-4d chars"] +} {5.1 5.1} +.t delete 5.4 +.t tag add elide 5.5 5.6 +test text-9.27 {TextWidgetCmd procedure, "get" option} { + .t get -displaychars 5.2 5.8 +} {Grl} +.t tag delete elide +.t mark unset a +.t mark unset b +.t mark unset c +test text-9.2.1 {TextWidgetCmd procedure, "count" option} { + list [catch {.t count} msg] $msg +} {1 {wrong # args: should be ".t count ?options? index1 index2"}} +test text-9.2.2.1 {TextWidgetCmd procedure, "count" option} { + list [catch {.t count blah 1.0 2.0} msg] $msg +} {1 {bad option "blah" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels}} +test text-9.2.2 {TextWidgetCmd procedure, "count" option} { + list [catch {.t count a b} msg] $msg +} {1 {bad text index "a"}} +test text-9.2.3 {TextWidgetCmd procedure, "count" option} { + list [catch {.t count @q 3.1} msg] $msg +} {1 {bad text index "@q"}} +test text-9.2.4 {TextWidgetCmd procedure, "count" option} { + list [catch {.t count 3.1 @r} msg] $msg +} {1 {bad text index "@r"}} +test text-9.2.5 {TextWidgetCmd procedure, "count" option} { + .t count 5.7 5.3 +} {-4} +test text-9.2.6 {TextWidgetCmd procedure, "count" option} { + .t count 5.3 5.5 +} {2} +test text-9.2.7 {TextWidgetCmd procedure, "count" option} { + .t count 5.3 end +} {29} +.t mark set a 5.3 +.t mark set b 5.3 +.t mark set c 5.5 +test text-9.2.8 {TextWidgetCmd procedure, "count" option} { + .t count 5.2 5.7 +} {5} +test text-9.2.9 {TextWidgetCmd procedure, "count" option} { + .t count 5.2 5.3 +} {1} +test text-9.2.10 {TextWidgetCmd procedure, "count" option} { + .t count 5.2 5.4 +} {2} +test text-9.2.17 {TextWidgetCmd procedure, "count" option} { + list [catch {.t count 5.2 foo} msg] $msg +} {1 {bad text index "foo"}} +.t tag configure elide -elide 1 +.t tag add elide 2.2 3.4 +.t tag add elide 4.0 4.1 +test text-9.2.18 {TextWidgetCmd procedure, "count" option} { + .t count -displayindices 2.0 3.0 +} {2} +test text-9.2.19 {TextWidgetCmd procedure, "count" option} { + .t count -displayindices 2.2 3.0 +} {0} +test text-9.2.20 {TextWidgetCmd procedure, "count" option} { + .t count -displayindices 2.0 4.2 +} {5} +# Create one visible and one invisible window +frame .t.w1 +frame .t.w2 +.t mark set a 2.2 +# Creating this window here means that the elidden text +# now starts at 2.3, but 'a' is automatically moved to 2.3 +.t window create 2.1 -window .t.w1 +.t window create 3.1 -window .t.w2 +test text-9.2.21 {TextWidgetCmd procedure, "count" option} { + .t count -displayindices 2.0 3.0 +} {3} +test text-9.2.22 {TextWidgetCmd procedure, "count" option} { + .t count -displayindices 2.2 3.0 +} {1} +test text-9.2.23 {TextWidgetCmd procedure, "count" option} { + .t count -displayindices a 3.0 +} {0} +test text-9.2.24 {TextWidgetCmd procedure, "count" option} { + .t count -displayindices 2.0 4.2 +} {6} +test text-9.2.25 {TextWidgetCmd procedure, "count" option} { + .t count -displaychars 2.0 3.0 +} {2} +test text-9.2.26 {TextWidgetCmd procedure, "count" option} { + .t count -displaychars 2.2 3.0 +} {1} +test text-9.2.27 {TextWidgetCmd procedure, "count" option} { + .t count -displaychars a 3.0 +} {0} +test text-9.2.28 {TextWidgetCmd procedure, "count" option} { + .t count -displaychars 2.0 4.2 +} {5} +test text-9.2.29 {TextWidgetCmd procedure, "count" option} { + list [.t count -indices 2.2 3.0] [.t count 2.2 3.0] +} {10 10} +test text-9.2.30 {TextWidgetCmd procedure, "count" option} { + list [.t count -indices a 3.0] [.t count a 3.0] +} {9 9} +test text-9.2.31 {TextWidgetCmd procedure, "count" option} { + .t count -indices 2.0 4.2 +} {21} +test text-9.2.32 {TextWidgetCmd procedure, "count" option} { + .t count -chars 2.2 3.0 +} {10} +test text-9.2.33 {TextWidgetCmd procedure, "count" option} { + .t count -chars a 3.0 +} {9} +test text-9.2.34 {TextWidgetCmd procedure, "count" option} { + .t count -chars 2.0 4.2 +} {19} +destroy .t.w1 +destroy .t.w2 +set current [.t get 1.0 end-1c] +.t delete 1.0 end +.t insert end [string repeat "abcde " 50]\n +.t insert end [string repeat "fghij " 50]\n +.t insert end [string repeat "klmno " 50] +test text-9.2.35 {TextWidgetCmd procedure, "count" option} { + .t count -lines 1.0 end +} {3} +test text-9.2.36 {TextWidgetCmd procedure, "count" option} { + .t count -lines end 1.0 +} {-3} +test text-9.2.37 {TextWidgetCmd procedure, "count" option} { + list [catch {.t count -lines 1.0 2.0 3.0} res] $res +} {1 {bad option "1.0" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels}} +test text-9.2.38 {TextWidgetCmd procedure, "count" option} { + .t count -lines end end +} {0} +test text-9.2.39 {TextWidgetCmd procedure, "count" option} { + .t count -lines 1.5 2.5 +} {1} +test text-9.2.40 {TextWidgetCmd procedure, "count" option} { + .t count -lines 2.5 "2.5 lineend" +} {0} +test text-9.2.41 {TextWidgetCmd procedure, "count" option} { + .t count -lines 2.7 "1.0 lineend" +} {-1} +test text-9.2.42 {TextWidgetCmd procedure, "count" option} { + set old_wrap [.t cget -wrap] + .t configure -wrap none + set res [.t count -displaylines 1.0 end] + .t configure -wrap $old_wrap + set res +} {3} +test text-9.2.43 {TextWidgetCmd procedure, "count" option} { + .t count -lines -chars -indices -displaylines 1.0 end +} {3 903 903 45} +.t configure -wrap none + +# Newer tags are higher priority +.t tag configure elide1 -elide 0 +.t tag configure elide2 -elide 1 +.t tag configure elide3 -elide 0 +.t tag configure elide4 -elide 1 + +test text-0.2.44.0 {counting with tag priority eliding} { + .t delete 1.0 end + .t insert end "hello" + list [.t count -displaychars 1.0 1.0] \ + [.t count -displaychars 1.0 1.1] \ + [.t count -displaychars 1.0 1.2] \ + [.t count -displaychars 1.0 1.3] \ + [.t count -displaychars 1.0 1.4] \ + [.t count -displaychars 1.0 1.5] \ + [.t count -displaychars 1.0 1.6] \ + [.t count -displaychars 1.0 2.6] \ +} {0 1 2 3 4 5 5 6} +test text-0.2.44 {counting with tag priority eliding} { + .t delete 1.0 end + .t insert end "hello" + .t tag add elide1 1.2 1.4 + .t count -displaychars 1.0 1.5 +} {5} +test text-0.2.45 {counting with tag priority eliding} { + .t delete 1.0 end + .t insert end "hello" + .t tag add elide2 1.2 1.4 + .t count -displaychars 1.0 1.5 +} {3} +test text-0.2.46 {counting with tag priority eliding} { + set res {} + .t delete 1.0 end + .t insert end "hello" + .t tag add elide2 1.2 1.4 + .t tag add elide1 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] + .t delete 1.0 end + .t insert end "hello" + .t tag add elide1 1.2 1.4 + .t tag add elide2 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] +} {3 3} +test text-0.2.47 {counting with tag priority eliding} { + set res {} + .t delete 1.0 end + .t insert end "hello" + .t tag add elide2 1.2 1.4 + .t tag add elide3 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] + .t delete 1.0 end + .t insert end "hello" + .t tag add elide3 1.2 1.4 + .t tag add elide3 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] +} {5 5} +test text-0.2.48 {counting with tag priority eliding} { + set res {} + .t delete 1.0 end + .t insert end "hello" + .t tag add elide2 1.2 1.4 + .t tag add elide3 1.2 1.4 + .t tag add elide4 1.2 1.4 + .t tag add elide1 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] + .t delete 1.0 end + .t insert end "hello" + .t tag add elide1 1.2 1.4 + .t tag add elide4 1.2 1.4 + .t tag add elide2 1.2 1.4 + .t tag add elide3 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] +} {3 3} +test text-0.2.49 {counting with tag priority eliding} { + set res {} + .t delete 1.0 end + .t insert end "hello" + .t tag add elide2 1.2 1.4 + .t tag add elide3 1.2 1.4 + .t tag add elide1 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] + .t delete 1.0 end + .t insert end "hello" + .t tag add elide1 1.2 1.4 + .t tag add elide2 1.2 1.4 + .t tag add elide3 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] +} {5 5} +test text-0.2.50 {counting with tag priority eliding} { + set res {} + .t delete 1.0 end + .t insert end "hello" + .t tag add elide2 1.0 1.5 + .t tag add elide1 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] + lappend res [.t count -displaychars 1.1 1.5] + lappend res [.t count -displaychars 1.2 1.5] + lappend res [.t count -displaychars 1.3 1.5] + .t delete 1.0 end + .t insert end "hello" + .t tag add elide1 1.0 1.5 + .t tag add elide2 1.2 1.4 + lappend res [.t count -displaychars 1.0 1.5] + lappend res [.t count -displaychars 1.1 1.5] + lappend res [.t count -displaychars 1.2 1.5] + lappend res [.t count -displaychars 1.3 1.5] +} {0 0 0 0 3 2 1 1} +test text-0.2.51 {counting with tag priority eliding} { + set res {} + .t delete 1.0 end + .t tag configure WELCOME -elide 1 + .t tag configure SYSTEM -elide 0 + .t tag configure TRAFFIC -elide 1 + .t insert end "\n" {SYSTEM TRAFFIC} + .t insert end "\n" WELCOME + lappend res [.t count -displaychars 1.0 end] + lappend res [.t count -displaychars 1.0 end-1c] + lappend res [.t count -displaychars 1.0 1.2] + lappend res [.t count -displaychars 2.0 end] + lappend res [.t count -displaychars 2.0 end-1c] + lappend res [.t index "1.0 +1 indices"] + lappend res [.t index "1.0 +1 display indices"] + lappend res [.t index "1.0 +1 display chars"] + lappend res [.t index end] + lappend res [.t index "end -1 indices"] + lappend res [.t index "end -1 display indices"] + lappend res [.t index "end -1 display chars"] + lappend res [.t index "end -2 indices"] + lappend res [.t index "end -2 display indices"] + lappend res [.t index "end -2 display chars"] +} {1 0 0 1 0 2.0 4.0 4.0 4.0 3.0 3.0 3.0 2.0 1.0 1.0} + +.t delete 1.0 end +.t insert end $current +unset current test text-10.1 {TextWidgetCmd procedure, "index" option} { list [catch {.t index} msg] $msg @@ -389,7 +829,7 @@ test text-10.2 {TextWidgetCmd procedure, "index" option} { } {1 {wrong # args: should be ".t index index"}} test text-10.3 {TextWidgetCmd procedure, "index" option} { list [catch {.t in a b} msg] $msg -} {1 {bad option "in": must be bbox, cget, compare, configure, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} +} {1 {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}} test text-10.4 {TextWidgetCmd procedure, "index" option} { list [catch {.t index @xyz} msg] $msg } {1 {bad text index "@xyz"}} @@ -452,7 +892,7 @@ test text-11.10 {TextWidgetCmd procedure, "insert" option} { test text-12.1 {ConfigureText procedure} { list [catch {.t2 configure -state foobar} msg] $msg -} {1 {bad state value "foobar": must be normal or disabled}} +} {1 {bad state "foobar": must be disabled or normal}} test text-12.2 {ConfigureText procedure} { .t2 configure -spacing1 -2 -spacing2 1 -spacing3 1 list [.t2 cget -spacing1] [.t2 cget -spacing2] [.t2 cget -spacing3] @@ -480,7 +920,7 @@ test text-12.6 {ConfigureText procedure} { } {} test text-12.7 {ConfigureText procedure} { list [catch {.t2 configure -wrap bogus} msg] $msg -} {1 {bad wrap mode "bogus": must be char, none, or word}} +} {1 {bad wrap "bogus": must be char, none, or word}} test text-12.8 {ConfigureText procedure} { .t2 configure -selectborderwidth 17 -selectforeground #332211 \ -selectbackground #abc @@ -538,7 +978,6 @@ test text-12.15 {ConfigureText procedure} { test text-12.16 {ConfigureText procedure} {fonts} { # This test is non-portable because the window size will vary depending # on the font size, which can vary. - catch {destroy .t2} toplevel .t2 text .t2.t -width 20 -height 10 @@ -552,7 +991,6 @@ test text-12.17 {ConfigureText procedure} { # was a certain minimum size and it was interfering with the size # requested by the -setgrid. The "overrideredirect" gets rid of the # titlebar so the toplevel can shrink to the appropriate size. - catch {destroy .t2} toplevel .t2 wm overrideredirect .t2 1 @@ -567,7 +1005,6 @@ test text-12.18 {ConfigureText procedure} { # was a certain minimum size and it was interfering with the size # requested by the -setgrid. The "overrideredirect" gets rid of the # titlebar so the toplevel can shrink to the appropriate size. - catch {destroy .t2} toplevel .t2 wm overrideredirect .t2 1 @@ -900,7 +1337,7 @@ test text-18.5 {TextFetchSelection procedure, long selections} { selection get } $x\n -test text-19.1 {TkTextLostSelection procedure} {unixOnly} { +test text-19.1 {TkTextLostSelection procedure} unix { catch {destroy .t2} text .t2 .t2 insert 1.0 "abc\ndef\nghijk\n1234" @@ -908,7 +1345,7 @@ test text-19.1 {TkTextLostSelection procedure} {unixOnly} { .t.e select to 1 .t2 tag ranges sel } {} -test text-19.2 {TkTextLostSelection procedure} {macOrPc} { +test text-19.2 {TkTextLostSelection procedure} win { catch {destroy .t2} text .t2 .t2 insert 1.0 "abc\ndef\nghijk\n1234" @@ -933,10 +1370,13 @@ test text-19.3 {TkTextLostSelection procedure} { .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" test text-20.1 {TextSearchCmd procedure, argument parsing} { list [catch {.t search -} msg] $msg -} {1 {bad switch "-": must be --, -backward, -count, -elide, -exact, -forward, -nocase, or -regexp}} +} {1 {bad switch "-": must be --, -all, -backward, -count, -elide, -exact, -forward, -nocase, -nolinestop, -overlap, -regexp, or -strictlimits}} test text-20.2 {TextSearchCmd procedure, -backwards option} { .t search -backwards xyz 1.4 } {1.1} +test text-20.2.1 {TextSearchCmd procedure, -all option} { + .t search -all xyz 1.4 +} {1.5 3.0 3.5 1.1} test text-20.3 {TextSearchCmd procedure, -forwards option} { .t search -forwards xyz 1.4 } {1.5} @@ -956,9 +1396,19 @@ test text-20.7 {TextSearchCmd procedure, -count option} { test text-20.8 {TextSearchCmd procedure, -nocase option} { list [.t search -nocase BaR 1.1] [.t search BaR 1.1] } {2.13 2.23} -test text-20.9 {TextSearchCmd procedure, -nocase option} { - .t search -n BaR 1.1 +test text-20.9 {TextSearchCmd procedure, -n ambiguous option} { + list [catch {.t search -n BaR 1.1} msg] $msg +} {1 {bad switch "-n": must be --, -all, -backward, -count, -elide, -exact, -forward, -nocase, -nolinestop, -overlap, -regexp, or -strictlimits}} +test text-20.9.1 {TextSearchCmd procedure, -nocase option} { + .t search -noc BaR 1.1 } {2.13} +test text-20.9.2 {TextSearchCmd procedure, -nolinestop option} { + list [catch {.t search -nolinestop BaR 1.1} msg] $msg +} {1 {the "-nolinestop" option requires the "-regexp" option to be present}} +test text-20.9.3 {TextSearchCmd procedure, -nolinestop option} { + set msg "" + list [.t search -nolinestop -regexp -count msg e.*o 1.1] $msg +} {1.14 32} test text-20.10 {TextSearchCmd procedure, -- option} { .t search -- -forward 1.0 } {2.4} @@ -1007,15 +1457,15 @@ test text-20.23 {TextSearchCmd procedure, extract line contents} { test text-20.24 {TextSearchCmd procedure, stripping newlines} { .t search the\n 1.0 } {1.12} -test text-20.25 {TextSearchCmd procedure, stripping newlines} { +test text-20.25 {TextSearchCmd procedure, handling newlines} { .t search -regexp the\n 1.0 -} {} +} {1.12} test text-20.26 {TextSearchCmd procedure, stripping newlines} { .t search -regexp {the$} 1.0 } {1.12} -test text-20.27 {TextSearchCmd procedure, stripping newlines} { +test text-20.27 {TextSearchCmd procedure, handling newlines} { .t search -regexp \n 1.0 -} {} +} {1.15} test text-20.28 {TextSearchCmd procedure, line case conversion} { list [.t search -nocase bar 2.18] [.t search bar 2.18] } {2.23 2.13} @@ -1040,7 +1490,7 @@ test text-20.34 {TextSearchCmd procedure, firstChar and lastChar} { test text-20.35 {TextSearchCmd procedure, firstChar and lastChar} { .t search {} end } {1.0} -test text-20.36 {TextSearchCmd procedure, regexp finds empty lines} { +test text-20.35a {TextSearchCmd procedure, regexp finds empty lines} { # Test for fix of bug #1643 .t insert end "\n" tk::TextSetCursor .t 4.0 @@ -1100,10 +1550,16 @@ test text-20.47 {TextSearchCmd procedure, checking stopIndex} { } {{} 2.13 2.13 {}} test text-20.48 {TextSearchCmd procedure, checking stopIndex} { list [.t search -backwards bar 2.20 2.13] \ - [.t search -backwards bar 2.20 2.14] \ - [.t search -backwards bar 2.14 2.13] \ - [.t search -backwards bar 2.13 2.13] + [.t search -backwards bar 2.20 2.14] \ + [.t search -backwards bar 2.14 2.13] \ + [.t search -backwards bar 2.13 2.13] } {2.13 {} 2.13 {}} +test text-20.48.1 {TextSearchCmd procedure, checking stopIndex} { + list [.t search -backwards -strict bar 2.20 2.13] \ + [.t search -backwards -strict bar 2.20 2.14] \ + [.t search -backwards -strict bar 2.14 2.13] \ + [.t search -backwards -strict bar 2.13 2.13] +} {2.13 {} {} {}} test text-20.49 {TextSearchCmd procedure, embedded windows and index/count} { frame .t.f1 -width 20 -height 20 -relief raised -bd 2 frame .t.f2 -width 20 -height 20 -relief raised -bd 2 @@ -1162,7 +1618,9 @@ test text-20.61 {TextSearchCmd procedure, special cases} { test text-20.62 {TextSearchCmd, freeing copy of pattern} { # This test doesn't return a result, but it will generate # a core leak if the pattern copy isn't properly freed. - + # (actually in Tk 8.5 objectification means there is no + # longer a copy of the pattern, but we leave this test in + # anyway). set p abcdefg1234567890 set p $p$p$p$p$p$p$p$p set p $p$p$p$p$p @@ -1188,7 +1646,6 @@ test text-20.65 {TextSearchCmd, unicode with non-text segments} { destroy .b1 set result } {1.3 3} - test text-20.66 {TextSearchCmd, hidden text does not affect match index} { deleteWindows pack [text .t2] @@ -1217,7 +1674,6 @@ test text-20.69 {TextSearchCmd, hidden text does not affect match index} { .t2 tag add hidden 2.0 3.0 .t2 search boo 1.0 } 3.3 - test text-20.70 {TextSearchCmd, -regexp -nocase searches} { catch {destroy .t} pack [text .t] @@ -1242,11 +1698,1075 @@ test text-20.72 {TextSearchCmd, -regexp -nocase searches} { destroy .t set res } 1.0 - +test text-20.73 {TextSearchCmd, hidden text and start index} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search bar 1.3 +} 1.3 +test text-20.74 {TextSearchCmd, hidden text shouldn't influence start index} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.0 1.2 + .t2 search bar 1.3 +} 1.3 +test text-20.75 {TextSearchCmd, hidden text inside match must count in length} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.2 1.4 + list [.t2 search -count foo foar 1.3] $foo +} {1.0 6} +test text-20.75.1 {TextSearchCmd, hidden text inside match must count in length} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.2 1.4 + list \ + [.t2 search -strict -count foo foar 1.3] \ + [.t2 search -strict -count foo foar 2.3] $foo +} {{} 1.0 6} +test text-20.76 {TextSearchCmd, hidden text and start index} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search -regexp bar 1.3 +} 1.3 +test text-20.77 {TextSearchCmd, hidden text shouldn't influence start index} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.0 1.2 + .t2 search -regexp bar 1.3 +} 1.3 +test text-20.78 {TextSearchCmd, hidden text inside match must count in length} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.2 1.4 + list [.t2 search -regexp -count foo foar 1.3] $foo +} {1.0 6} +test text-20.78.1 {TextSearchCmd, hidden text inside match must count in length} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.2 1.4 + list [.t2 search -count foo foar 1.3] $foo +} {1.0 6} +test text-20.78.2 {TextSearchCmd, hidden text inside match must count in length} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.2 1.4 + .t2 search -strict -count foo foar 1.3 +} {} +test text-20.78.3 {TextSearchCmd, hidden text inside match must count in length} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.2 1.4 + .t2 tag add hidden 2.2 2.4 + list [.t2 search -regexp -all -count foo foar 1.3] $foo +} {{2.0 3.0 1.0} {6 4 6}} +test text-20.78.4 {TextSearchCmd, hidden text inside match must count in length} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.2 1.4 + .t2 tag add hidden 2.2 2.4 + list [.t2 search -all -count foo foar 1.3] $foo +} {{2.0 3.0 1.0} {6 4 6}} +test text-20.78.5 {TextSearchCmd, hidden text inside match must count in length} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoar" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.2 1.4 + .t2 tag add hidden 2.2 2.4 + list [.t2 search -strict -all -count foo foar 1.3] $foo +} {{2.0 3.0} {6 4}} +test text-20.78.6 {TextSearchCmd, single line with -all} { + deleteWindows + pack [text .t2] + .t2 insert end " X\n X\n X\n X\n X\n X\n" + .t2 search -all -regexp { +| *\n} 1.0 end +} {1.0 1.2 2.0 2.2 3.0 3.2 4.0 4.2 5.0 5.2 6.0 6.2 7.0} +test text-20.79 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -count foo foobar\nfoo 1.0] $foo +} {1.0 10} +test text-20.80 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -count foo bar\nfoo 1.0] $foo +} {1.3 7} +test text-20.81 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -count foo \nfoo 1.0] $foo +} {1.6 4} +test text-20.82 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -count foo bar\nfoobar\nfoo 1.0] $foo +} {1.3 14} +test text-20.83 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search -count foo bar\nfoobar\nfoobanearly 1.0 +} {} +test text-20.84 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -regexp -count foo foobar\nfoo 1.0] $foo +} {1.0 10} +test text-20.85 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -regexp -count foo bar\nfoo 1.0] $foo +} {1.3 7} +test text-20.86 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -regexp -count foo \nfoo 1.0] $foo +} {1.6 4} +test text-20.87 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -regexp -count foo bar\nfoobar\nfoo 1.0] $foo +} {1.3 14} +test text-20.88 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search -regexp -count foo bar\nfoobar\nfoobanearly 1.0 +} {} +test text-20.89 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfaoobar\nfoobar" + .t2 search -regexp -count foo bar\nfoo 1.0 +} {2.4} +test text-20.90 {TextSearchCmd, multiline matching end of window} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfaoobar\nfoobar" + .t2 search -regexp -count foo bar\nfoobar\n\n 1.0 +} {} +test text-20.91 {TextSearchCmd, multiline matching end of window} { + deleteWindows + pack [text .t2] + .t2 search "\n\n" 1.0 +} {} +test text-20.92 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -backwards -count foo foobar\nfoo end] $foo +} {2.0 10} +test text-20.93 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -backwards -count foo bar\nfoo 1.0] $foo +} {2.3 7} +test text-20.94 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -backwards -count foo \nfoo 1.0] $foo +} {2.6 4} +test text-20.95 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -backwards -count foo bar\nfoobar\nfoo 1.0] $foo +} {1.3 14} +test text-20.96 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search -backwards -count foo bar\nfoobar\nfoobanearly 1.0 +} {} +test text-20.97 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -backwards -regexp -count foo foobar\nfoo end] $foo +} {2.0 10} +test text-20.97.1 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -backwards -regexp -count foo foobar\nfo end] $foo +} {2.0 9} +test text-20.98 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -backwards -regexp -count foo bar\nfoo 1.0] $foo +} {2.3 7} +test text-20.99 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -backwards -regexp -count foo \nfoo 1.0] $foo +} {2.6 4} +test text-20.100 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + list [.t2 search -backwards -regexp -count foo bar\nfoobar\nfoo 1.0] $foo +} {1.3 14} +test text-20.101 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search -backwards -regexp -count foo bar\nfoobar\nfoobanearly 1.0 +} {} +test text-20.102 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfaoobar\nfoobar" + .t2 search -backwards -regexp -count foo bar\nfoo 1.0 +} {2.4} +test text-20.103 {TextSearchCmd, multiline matching end of window} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfaoobar\nfoobar" + .t2 search -backwards -regexp -count foo bar\nfoobar\n\n 1.0 +} {} +test text-20.104 {TextSearchCmd, multiline matching end of window} { + deleteWindows + pack [text .t2] + .t2 search -backwards "\n\n" 1.0 +} {} +test text-20.105 {TextSearchCmd, multiline regexp matching} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 { Tcl_Obj *objPtr)); +static Tcl_Obj* FSNormalizeAbsolutePath + _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));} + set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" + append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" + append markExpr "\[ \n\t\r\]*\\()" + .t2 search -forwards -regexp $markExpr 1.41 end +} {} +test text-20.106 {TextSearchCmd, multiline regexp matching} { + # Practical example which used to crash Tk, but only after the + # search is complete. This is memory corruption caused by + # a bug in Tcl's handling of string objects. + # (Tcl bug 635200) + deleteWindows + pack [text .t2] + .t2 insert 1.0 {static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static Tcl_Obj* FSNormalizeAbsolutePath + _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));} + set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" + append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" + append markExpr "\[ \n\t\r\]*\\()" + .t2 search -forwards -regexp $markExpr 1.41 end +} {} +test text-20.107 {TextSearchCmd, multiline regexp matching} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 { +static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static Tcl_Obj* FSNormalizeAbsolutePath + _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));} + set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" + append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" + append markExpr "\[ \n\t\r\]*\\()" + .t2 search -backwards -all -regexp $markExpr end +} {2.0} +test text-20.108 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search -all -regexp -count foo bar\nfoo 1.0 +} {1.3 2.3} +test text-20.109 {TextSearchCmd, multiline matching} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search -all -backwards -regexp -count foo bar\nfoo 1.0 +} {2.3 1.3} +test text-20.110 {TextSearchCmd, wrapping and limits} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search -- "blah" 3.3 1.3 +} {} +test text-20.111 {TextSearchCmd, wrapping and limits} { + deleteWindows + pack [text .t2] + .t2 insert end "foobar\nfoobar\nfoobar" + .t2 search -backwards -- "blah" 1.3 3.3 +} {} +test text-20.112 {TextSearchCmd, wrapping and limits} { + deleteWindows + pack [text .t2] + .t2 insert end "if (stringPtr->uallocated > 0) \{x" + .t2 search -backwards -regexp -- "\[\]\")\}\[(\{\]" "1.32" 1.0 +} {1.31} +test text-20.113 {TextSearchCmd, wrapping and limits} { + deleteWindows + pack [text .t2] + .t2 insert end "if (stringPtr->uallocated > 0) \{x" + .t2 search -regexp -- "\[\]\")\}\[(\{\]" 1.30 "1.0 lineend" +} {1.31} +test text-20.114 {TextSearchCmd, wrapping and limits} { + deleteWindows + pack [text .t2] + .t2 insert end "if (stringPtr->uallocated > 0) \{x" + .t2 search -backwards -all -regexp -- "\[\]\")\}\[(\{\]" "1.32" 1.0 +} {1.31 1.29 1.3} +test text-20.115 {TextSearchCmd, wrapping and limits} { + deleteWindows + pack [text .t2] + .t2 insert end "if (stringPtr->uallocated > 0) \{x" + .t2 search -all -regexp -- "\[\]\")\}\[(\{\]" 1.0 "1.0 lineend" +} {1.3 1.29 1.31} +test text-20.116 {TextSearchCmd, wrapping and limits} { + deleteWindows + pack [text .t2] + .t2 insert end "if (stringPtr->uallocated > 0) \{x" + .t2 search -backwards -- "\{" "1.32" 1.0 +} {1.31} +test text-20.117 {TextSearchCmd, wrapping and limits} { + deleteWindows + pack [text .t2] + .t2 insert end "if (stringPtr->uallocated > 0) \{x" + .t2 search -- "\{" 1.30 "1.0 lineend" +} {1.31} +test text-20.118 {TextSearchCmd, multiline regexp matching} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 { + +void +Tcl_SetObjLength(objPtr, length) + register Tcl_Obj *objPtr; /* Pointer to object. This object must + * not currently be shared. */ + register int length; /* Number of bytes desired for string + * representation of object, not including + * terminating null byte. */ +\{ + char *new; +} + set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" + append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" + append markExpr "\[ \n\t\r\]*\\()" + .t2 search -all -regexp -- $markExpr 1.0 +} {4.0} +test text-20.119 {TextSearchCmd, multiline regexp matching} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "first line\nlast line of text" + set markExpr {^[a-z]+} + # This should not match, and should not wrap + .t2 search -regexp -- $markExpr end end +} {} +test text-20.120 {TextSearchCmd, multiline regexp matching} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "first line\nlast line of text" + set markExpr {^[a-z]+} + # This should not match, and should not wrap + .t2 search -regexp -- $markExpr end+10c end +} {} +test text-20.121 {TextSearchCmd, multiline regexp matching} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "first line\nlast line of text" + set markExpr {^[a-z]+} + # This should not match, and should not wrap + .t2 search -regexp -backwards -- $markExpr 1.0 1.0 +} {} +test text-20.122 {TextSearchCmd, regexp linestop} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "first line\nlast line of text" + .t2 search -regexp -- {i.*x} 1.0 +} {2.6} +test text-20.123 {TextSearchCmd, multiline regexp nolinestop matching} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "first line\nlast line of text" + .t2 search -regexp -nolinestop -- {i.*x} 1.0 +} {1.1} +test text-20.124 {TextSearchCmd, regexp linestop} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "first line\nlast line of text" + .t2 search -regexp -all -overlap -- {i.*x} 1.0 +} {2.6} +test text-20.124.1 {TextSearchCmd, regexp linestop} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "first line\nlast line of text" + .t2 search -regexp -all -- {i.*x} 1.0 +} {2.6} +test text-20.125 {TextSearchCmd, multiline regexp nolinestop matching} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "first line\nlast line of text" + list [.t2 search -regexp -all -overlap -count c -nolinestop -- {i.*x} 1.0] $c +} {{1.1 2.6} {26 10}} +test text-20.125.1 {TextSearchCmd, multiline regexp nolinestop matching} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "first line\nlast line of text" + list [.t2 search -regexp -all -count c -nolinestop -- {i.*x} 1.0] $c +} {1.1 26} +test text-20.126 {TextSearchCmd, stop at end of line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 " \t\n last line of text" + .t2 search -regexp -nolinestop -- {[^ \t]} 1.0 +} {1.3} +test text-20.127 {TextSearchCmd, overlapping all matches} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde abcde" + list [.t2 search -regexp -all -overlap -count c -- {\w+} 1.0] $c +} {{1.0 1.6} {5 5}} +test text-20.127.1 {TextSearchCmd, non-overlapping all matches} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde abcde" + list [.t2 search -regexp -all -count c -- {\w+} 1.0] $c +} {{1.0 1.6} {5 5}} +test text-20.128 {TextSearchCmd, stop at end of line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde abcde" + list [.t2 search -backwards -regexp -all -count c -- {\w+} 1.0] $c +} {{1.6 1.0} {5 5}} +test text-20.129 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t2 search -backwards -regexp -count c -- {Z\w+} 1.21 1.5] $c +} {1.8 8} +test text-20.130 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t2 search -backwards -all -overlap -regexp -count c -- {Z\w+} 1.21 1.5] $c +} {1.8 8} +test text-20.130.1 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t2 search -backwards -all -regexp -count c -- {Z\w+} 1.21 1.5] $c +} {1.8 8} +test text-20.131 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t2 search -backwards -overlap -all -regexp -count c -- {Z\w+} 1.21 1.1] $c +} {1.4 12} +test text-20.131.1 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t2 search -backwards -overlap -all -regexp -count c -- {Z[^Z]+Z} 1.21 1.1] $c +} {{1.8 1.4} {5 5}} +test text-20.131.2 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t2 search -backwards -all -regexp -count c -- {Z\w+} 1.21 1.1] $c +} {1.4 12} +test text-20.132 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + .t2 insert 1.0 "bla ZabcZdefZghi and some text again\n" + list [.t2 search -backwards -all -overlap -regexp -count c -- {Z\w+} 2.21 1.5] $c +} {{2.4 1.8} {12 8}} +test text-20.132.1 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + .t2 insert 1.0 "bla ZabcZdefZghi and some text again\n" + list [.t2 search -backwards -all -regexp -count c -- {Z\w+} 2.21 1.5] $c +} {{2.4 1.8} {12 8}} +test text-20.133 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + .t2 insert 1.0 "bla ZabcZdefZghi and some text again\n" + list [.t2 search -backwards -overlap -all -regexp -count c -- {Z\w+} 2.21 1.1] $c +} {{2.4 1.4} {12 12}} +test text-20.133.1 {TextSearchCmd, backwards search stop index } { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "bla ZabcZdefZghi and some text again" + .t2 insert 1.0 "bla ZabcZdefZghi and some text again\n" + list [.t2 search -backwards -all -regexp -count c -- {Z\w+} 2.21 1.1] $c +} {{2.4 1.4} {12 12}} +test text-20.134 {TextSearchCmd, search -all example} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 { + +See the package: supersearch for more information. + + +See the package: incrementalSearch for more information. + +package: Brws . + + +See the package: marks for more information. + +} + set pat {package: ([a-zA-Z0-9][-a-zA-Z0-9._+#/]*)} + list [.t2 search -nolinestop -regexp -nocase -all -forwards \ + -count c -- $pat 1.0 end] $c +} {{3.8 6.8 8.0 11.8} {20 26 13 14}} +test text-20.135 {TextSearchCmd, backwards search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t2 search -backwards -regexp {fooba+rfoo} end +} {1.6} +test text-20.135.1 {TextSearchCmd, backwards search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t2 search -backwards -overlap -all -regexp {fooba+rfoo} end +} {1.6 1.0} +test text-20.135.2 {TextSearchCmd, backwards search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t2 search -backwards -all -regexp {fooba+rfoo} end +} {1.6} +test text-20.135.3 {TextSearchCmd, forwards search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t2 search -all -overlap -regexp {fooba+rfoo} end +} {1.0 1.6} +test text-20.135.4 {TextSearchCmd, forwards search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t2 search -all -regexp {fooba+rfoo} end +} {1.0} +test text-20.136 {TextSearchCmd, forward exact search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abababab" + .t2 search -exact -overlap -all {abab} 1.0 +} {1.0 1.2 1.4} +test text-20.136.1 {TextSearchCmd, forward exact search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abababab" + .t2 search -exact -all {abab} 1.0 +} {1.0 1.4} +test text-20.137 {TextSearchCmd, backward exact search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "ababababab" + .t2 search -exact -overlap -backwards -all {abab} end +} {1.6 1.4 1.2 1.0} +test text-20.137.1 {TextSearchCmd, backward exact search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "ababababab" + .t2 search -exact -backwards -all {abab} end +} {1.6 1.2} +test text-20.137.2 {TextSearchCmd, backward exact search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abababababab" + .t2 search -exact -backwards -all {abab} end +} {1.8 1.4 1.0} +test text-20.138 {TextSearchCmd, forward exact search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t2 search -exact -overlap -all "foo\nbar\nfoo" 1.0 +} {1.0 3.0 5.0} +test text-20.138.1 {TextSearchCmd, forward exact search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t2 search -exact -all "foo\nbar\nfoo" 1.0 +} {1.0 5.0} +test text-20.139 {TextSearchCmd, backward exact search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t2 search -exact -overlap -backward -all "foo\nbar\nfoo" end +} {5.0 3.0 1.0} +test text-20.140 {TextSearchCmd, backward exact search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t2 search -exact -backward -all "foo\nbar\nfoo" end +} {5.0 1.0} +test text-20.141 {TextSearchCmd, backward exact search overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t2 search -regexp -backward -overlap -all "foo\nbar\nfoo" end +} {5.0 3.0 1.0} +test text-20.142 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t2 search -regexp -backward -all "foo\nbar\nfoo" end +} {5.0 1.0} +test text-20.142a {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 " aasda asdj werwer" + .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 +} {1.7} +test text-20.143 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 " aasda asdj werwer" + .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.5 +} {1.7} +test text-20.144 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 " aasda asdj werwer" + .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.7 +} {1.7} +test text-20.145 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 " aasda asdj werwer" + .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.8 +} {1.8} +test text-20.146 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 " aasda asdj werwer" + .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.3 +} {1.7 1.3} +test text-20.147 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 " aasda asdj werwer" + .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.13 +} {} +test text-20.148 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 " aasda asdj werwer" + .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 2.0 1.3 +} {1.12 1.7 1.3} +test text-20.149 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 " aasda asdj werwer" + .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 1.3 +} {1.1 1.12 1.7 1.3} +test text-20.150 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\n" + .t2 search -regexp -backward -all -- {(\w+\n)+} end +} {1.0} +test text-20.151 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\n" + .t2 search -regexp -backward -all -- {(\w+\n)+} end 1.5 +} {2.0} +test text-20.152 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + .t2 search -regexp -backward -all -- {(\w+\n\w)+} end 1.5 +} {2.0} +test text-20.153 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + list [.t2 search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo +} {1.0 20} +test text-20.154 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + set res {} + lappend res \ + [list [.t2 search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo] \ + [list [.t2 search -regexp -all -count foo -- {(\w+)+} 1.0] $foo] +} {{1.0 20} {{1.0 2.0 3.0 4.0} {5 5 5 1}}} +test text-20.155 {TextSearchCmd, regexp search greedy} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + list [.t2 search -regexp -all -nolinestop -count foo -- {.*} 1.0] $foo +} {1.0 20} +test text-20.156 {TextSearchCmd, regexp search greedy} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + list [.t2 search -regexp -all -count foo -- {.*} 1.0] $foo +} {{1.0 2.0 3.0 4.0} {5 5 5 1}} +test text-20.157 {TextSearchCmd, regexp search greedy multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + list [.t2 search -regexp -count foo -- {(\w+\n\w)+} 1.0] $foo +} {1.0 19} +test text-20.158 {TextSearchCmd, regexp search greedy multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + list [.t2 search -regexp -backwards -count foo -- {(\w+\n\w)+} end] $foo +} {1.0 19} +test text-20.159 {TextSearchCmd, regexp search greedy multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + list [.t2 search -regexp -all -backwards -count foo -- {(\w+\n\w)+} end] $foo +} {1.0 19} +test text-20.160 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + .t2 search -regexp -backward -all -- {(\w+\n\w)+} end 1.5 +} {2.0} +test text-20.161 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + .t2 search -regexp -backward -all -- {(\w+\n\w)+} end 1.3 +} {1.3} +test text-20.162 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + list [.t2 search -regexp -forward -count foo -- {(\w+\n\w)+} 1.3] $foo +} {1.3 16} +test text-20.163 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + list [.t2 search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.3] $foo + # This result is somewhat debatable -- the two results do overlap, + # but only because the search has totally wrapped around back to + # the start. +} {{1.3 1.0} {16 19}} +test text-20.164 {TextSearchCmd, backward regexp search no-overlaps} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "abcde\nabcde\nabcde\na" + list [.t2 search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.0 1.3] $foo +} {1.0 19} +test text-20.165 {TextSearchCmd, regexp search multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n" + list [.t2 search -regexp -forward -all -count foo -- {(a+\n(b+\n))+} 1.0] $foo +} {1.0 20} +test text-20.166 {TextSearchCmd, regexp search complex cases} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n" + list [.t2 search -regexp -forward -all -count foo \ + -- {(a+\n(b+\n))+} 1.0] $foo +} {1.0 20} +test text-20.167 {TextSearchCmd, regexp search multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" + set foo {} + list [.t2 search -regexp -forward -all -count foo \ + -- {(b+\nc+\nb+)\na+} 1.0] $foo +} {2.0 19} +test text-20.168 {TextSearchCmd, regexp search multi-line} {knownBug} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" + set foo {} + list [.t2 search -regexp -forward -all -count foo \ + -- {(a+|b+\nc+\nb+)\na+} 1.0] $foo +} {2.0 19} +test text-20.169 {TextSearchCmd, regexp search multi-line} {knownBug} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" + set foo {} + list [.t2 search -regexp -forward -all -count foo \ + -- {(a+|b+\nc+\nb+)+\na+} 1.0] $foo +} {2.0 19} +test text-20.170 {TextSearchCmd, regexp search multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" + set foo {} + list [.t2 search -regexp -forward -all -count foo \ + -- {((a+|b+\nc+\nb+)+\n)+a+} 1.0] $foo +} {1.0 24} +test text-20.171 {TextSearchCmd, regexp search multi-line} {knownBug} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n" + list [.t2 search -regexp -backward -all -count foo \ + -- {b+\n|a+\n(b+\n)+} end] $foo +} {1.0 25} +test text-20.172 {TextSearchCmd, regexp search multi-line} {knownBug} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n" + .t2 search -regexp -backward -- {b+\n|a+\n(b+\n)+} end + # Should match at 1.0 for a true greedy match +} {1.0} +test text-20.172.1 {TextSearchCmd, regexp search multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "line0\nline1\nline1\nline1\nline1\nline2\nline2\nline2\nline3\n" + .t2 search -nolinestop -regexp -nocase -forwards -- {^(.*)\n(\1\n)+} 1.0 end + # Matches at 6.0 currently +} {2.0} +test text-20.173 {TextSearchCmd, regexp search multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "\naaaxxx\nyyy\n" + set res {} + lappend res [.t2 search -count c -regexp -- {x*\ny*} 2.0] $c + lappend res [.t2 search -count c -regexp -- {x*\ny*} 2.1] $c + set res +} {2.3 7 2.3 7} +test text-20.174 {TextSearchCmd, regexp search multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "\naaa\n\n\n\n\nxxx\n" + set res {} + lappend res [.t2 search -count c -regexp -- {\n+} 2.0] $c + lappend res [.t2 search -count c -regexp -- {\n+} 2.1] $c + set res +} {2.3 5 2.3 5} +test text-20.175 {TextSearchCmd, regexp search multi-line} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "\naaa\n\n\t \n\t\t\t \n\nxxx\n" + set res {} + lappend res [.t2 search -count c -regexp -- {(\n+(\t+ *)*)+} 2.0] $c + set res +} {2.3 13} +test text-20.176 {TextSearchCmd, empty search range} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "a\na\na\n" + .t2 search -- a 2.0 1.0 +} {} +test text-20.177 {TextSearchCmd, empty search range} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "a\na\na\n" + .t2 search -backwards -- a 1.0 2.0 +} {} +test text-20.178 {TextSearchCmd, empty search range} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "a\na\na\n" + .t2 search -- a 1.0 1.0 +} {} +test text-20.179 {TextSearchCmd, empty search range} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "a\na\na\n" + .t2 search -backwards -- a 2.0 2.0 +} {} +test text-20.180 {TextSearchCmd, elide up to match} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "a\nb\nc" + .t2 tag configure e -elide 1 + set res {} + lappend res [.t2 search -regexp a 1.0] + lappend res [.t2 search -regexp b 1.0] + lappend res [.t2 search -regexp c 1.0] + .t2 tag add e 1.0 2.0 + lappend res [.t2 search -regexp a 1.0] + lappend res [.t2 search -regexp b 1.0] + lappend res [.t2 search -regexp c 1.0] + lappend res [.t2 search -elide -regexp a 1.0] + lappend res [.t2 search -elide -regexp b 1.0] + lappend res [.t2 search -elide -regexp c 1.0] +} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} +test text-20.181 {TextSearchCmd, elide up to match, backwards} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "a\nb\nc" + .t2 tag configure e -elide 1 + set res {} + lappend res [.t2 search -backward -regexp a 1.0] + lappend res [.t2 search -backward -regexp b 1.0] + lappend res [.t2 search -backward -regexp c 1.0] + .t2 tag add e 1.0 2.0 + lappend res [.t2 search -backward -regexp a 1.0] + lappend res [.t2 search -backward -regexp b 1.0] + lappend res [.t2 search -backward -regexp c 1.0] + lappend res [.t2 search -backward -elide -regexp a 1.0] + lappend res [.t2 search -backward -elide -regexp b 1.0] + lappend res [.t2 search -backward -elide -regexp c 1.0] +} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} +test text-20.182 {TextSearchCmd, elide up to match} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "a\nb\nc" + .t2 tag configure e -elide 1 + set res {} + lappend res [.t2 search a 1.0] + lappend res [.t2 search b 1.0] + lappend res [.t2 search c 1.0] + .t2 tag add e 1.0 2.0 + lappend res [.t2 search a 1.0] + lappend res [.t2 search b 1.0] + lappend res [.t2 search c 1.0] + lappend res [.t2 search -elide a 1.0] + lappend res [.t2 search -elide b 1.0] + lappend res [.t2 search -elide c 1.0] +} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} +test text-20.183 {TextSearchCmd, elide up to match, backwards} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "a\nb\nc" + .t2 tag configure e -elide 1 + set res {} + lappend res [.t2 search -backward a 1.0] + lappend res [.t2 search -backward b 1.0] + lappend res [.t2 search -backward c 1.0] + .t2 tag add e 1.0 2.0 + lappend res [.t2 search -backward a 1.0] + lappend res [.t2 search -backward b 1.0] + lappend res [.t2 search -backward c 1.0] + lappend res [.t2 search -backward -elide a 1.0] + lappend res [.t2 search -backward -elide b 1.0] + lappend res [.t2 search -backward -elide c 1.0] +} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} +test text-20.184 {TextSearchCmd, elide up to match} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aa\nbb\ncc" + .t2 tag configure e -elide 1 + set res {} + lappend res [.t2 search ab 1.0] + lappend res [.t2 search bc 1.0] + .t2 tag add e 1.1 2.1 + lappend res [.t2 search ab 1.0] + lappend res [.t2 search b 1.0] + .t2 tag remove e 1.0 end + .t2 tag add e 2.1 3.1 + lappend res [.t2 search bc 1.0] + lappend res [.t2 search c 1.0] + .t2 tag remove e 1.0 end + .t2 tag add e 2.1 3.0 + lappend res [.t2 search bc 1.0] + lappend res [.t2 search c 1.0] +} {{} {} 1.0 2.1 2.0 3.1 2.0 3.0} +test text-20.185 {TextSearchCmd, elide up to match} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "aa\nbb\ncc" + .t2 tag configure e -elide 1 + set res {} + lappend res [.t2 search -regexp ab 1.0] + lappend res [.t2 search -regexp bc 1.0] + .t2 tag add e 1.1 2.1 + lappend res [.t2 search -regexp ab 1.0] + lappend res [.t2 search -regexp b 1.0] + .t2 tag remove e 1.0 end + .t2 tag add e 2.1 3.1 + lappend res [.t2 search -regexp bc 1.0] + lappend res [.t2 search -regexp c 1.0] + .t2 tag remove e 1.0 end + .t2 tag add e 2.1 3.0 + lappend res [.t2 search -regexp bc 1.0] + lappend res [.t2 search -regexp c 1.0] +} {{} {} 1.0 2.1 2.0 3.1 2.0 3.0} +test text-20.186 {TextSearchCmd, strict limits} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "Hello world!\nThis is a test\n" + .t2 search -strictlimits -- "world" 1.3 1.8 +} {} +test text-20.187 {TextSearchCmd, strict limits} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "Hello world!\nThis is a test\n" + .t2 search -strictlimits -- "world" 1.3 1.10 +} {} +test text-20.188 {TextSearchCmd, strict limits} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "Hello world!\nThis is a test\n" + .t2 search -strictlimits -- "world" 1.3 1.11 +} {1.6} +test text-20.189 {TextSearchCmd, strict limits backwards} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "Hello world!\nThis is a test\n" + .t2 search -strictlimits -backward -- "world" 2.3 1.8 +} {} +test text-20.190 {TextSearchCmd, strict limits backwards} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "Hello world!\nThis is a test\n" + .t2 search -strictlimits -backward -- "world" 2.3 1.6 +} {1.6} +test text-20.191 {TextSearchCmd, strict limits backwards} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "Hello world!\nThis is a test\n" + .t2 search -strictlimits -backward -- "world" 2.3 1.7 +} {} +test text-20.192 {TextSearchCmd, strict limits} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "Hello world!\nThis is a test\n" + .t2 search -regexp -strictlimits -- "world" 1.3 1.8 +} {} +test text-20.193 {TextSearchCmd, strict limits} { + deleteWindows + pack [text .t2] + .t2 insert 1.0 "Hello world!\nThis is a test\n" + .t2 search -regexp -strictlimits -backward -- "world" 2.3 1.8 +} {} + deleteWindows text .t2 -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 pack .t2 .t2 insert end "1\t2\t3\t4\t55.5" + test text-21.1 {TkTextGetTabs procedure} { list [catch {.t2 configure -tabs "\{{}"} msg] $msg } {1 {unmatched open brace in list}} @@ -1298,7 +2818,7 @@ test text-22.3 {TextDumpCmd procedure, bad args} { } {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}} test text-22.4 {TextDumpCmd procedure, bad args} { list [catch {.t dump -bogus} msg] $msg -} {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}} +} {1 {bad option "-bogus": must be -all, -command, -image, -mark, -tag, -text, or -window}} test text-22.5 {TextDumpCmd procedure, bad args} { list [catch {.t dump bogus} msg] $msg } {1 {bad text index "bogus"}} @@ -1318,12 +2838,10 @@ test text-22.9 {TextDumpCmd procedure, same indices} { test text-22.10 {TextDumpCmd procedure, negative range} { .t dump 1.5 1.0 } {} - .t delete 1.0 end .t insert end "Line One\nLine Two\nLine Three\nLine Four" .t mark set insert 1.0 .t mark set current 1.0 - test text-22.11 {TextDumpCmd procedure, stop at begin-line} { .t dump -text 1.0 2.0 } {text {Line One @@ -1333,7 +2851,6 @@ test text-22.12 {TextDumpCmd procedure, span multiple lines} { } {text {One } 1.5 text {Line Two } 2.0 text {Line Three} 3.0} - .t tag add x 2.0 2.end .t tag add y 1.0 end .t mark set m 2.4 @@ -1351,7 +2868,6 @@ test text-22.15 {TextDumpCmd procedure, tags only} { test text-22.16 {TextDumpCmd procedure, tags only} { .t dump -tag 1.0 end } {tagon y 1.0 tagon x 2.0 tagoff x 2.8 tagoff y 5.0} - .t mark set insert 1.0 .t mark set current 1.0 test text-22.17 {TextDumpCmd procedure, marks only} { @@ -1366,7 +2882,6 @@ test text-22.19 {TextDumpCmd procedure, marks only} { test text-22.20 {TextDumpCmd procedure, marks only} { .t dump -mark 1.0 end } {mark current 1.0 mark insert 1.0 mark m 2.4 mark n 4.0 mark END 5.0} - button .hello -text Hello .t window create 3.end -window .hello for {set i 0} {$i < 100} {incr i} { @@ -1379,7 +2894,6 @@ test text-22.21 {TextDumpCmd procedure, windows only} { test text-22.22 {TextDumpCmd procedure, windows only} { .t dump -window 5.0 end } {window {} 100.0} - .t delete 1.0 end eval {.t mark unset} [.t mark names] .t insert end "Line One\nLine Two\nLine Three\nLine Four" @@ -1420,6 +2934,15 @@ test text-22.26 {TextDumpCmd procedure, unicode characters} { .t insert 1.0 abc\xb1\xb1\xb1 .t dump -all 1.0 2.0 } "text abc\xb1\xb1\xb1 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6" +test text-22.27 {TextDumpCmd procedure, peer present} -setup { + destroy .t +} -body { + text .t + .t peer create .t.t + .t dump -all 1.0 end +} -cleanup { + destroy .t +} -result "mark insert 1.0 mark current 1.0 text {\n} 1.0" set l [interp hidden] deleteWindows @@ -1448,11 +2971,9 @@ test text-24.1 {bug fix - 1642} { test text-25.1 {TextEditCmd procedure, argument parsing} { list [catch {.t edit} msg] $msg } {1 {wrong # args: should be ".t edit option ?arg arg ...?"}} - test text-25.2 {TextEditCmd procedure, argument parsing} { list [catch {.t edit gorp} msg] $msg -} {1 {bad edit option "gorp": must be modified, redo, reset, separator or undo}} - +} {1 {bad edit option "gorp": must be modified, redo, reset, separator, or undo}} test text-25.3 {TextEditUndo procedure, undoing changes} { catch {destroy .t} text .t -undo 1 @@ -1463,7 +2984,6 @@ test text-25.3 {TextEditUndo procedure, undoing changes} { .t edit undo .t get 1.0 end } "line\n\n" - test text-25.4 {TextEditRedo procedure, redoing changes} { catch {destroy .t} text .t -undo 1 @@ -1475,7 +2995,6 @@ test text-25.4 {TextEditRedo procedure, redoing changes} { .t edit redo .t get 1.0 end } "line\nshould be back after redo\n\n" - test text-25.5 {TextEditUndo procedure, resetting stack} { catch {destroy .t} text .t -undo 1 @@ -1487,7 +3006,6 @@ test text-25.5 {TextEditUndo procedure, resetting stack} { catch {.t edit undo} msg set msg } "nothing to undo" - test text-25.6 {TextEditCmd procedure, insert separator} { catch {destroy .t} text .t -undo 1 @@ -1498,7 +3016,6 @@ test text-25.6 {TextEditCmd procedure, insert separator} { .t edit undo .t get 1.0 end } "line 1\n\n" - test text-25.7 {-autoseparators configuration option} { catch {destroy .t} text .t -undo 1 -autoseparators 0 @@ -1509,7 +3026,6 @@ test text-25.7 {-autoseparators configuration option} { .t edit undo .t get 1.0 end } "\n" - test text-25.8 {TextEditCmd procedure, modified flag} { catch {destroy .t} text .t @@ -1517,7 +3033,6 @@ test text-25.8 {TextEditCmd procedure, modified flag} { .t insert end "line 1\n" .t edit modified } {1} - test text-25.9 {TextEditCmd procedure, reset modified flag} { catch {destroy .t} text .t @@ -1526,7 +3041,6 @@ test text-25.9 {TextEditCmd procedure, reset modified flag} { .t edit modified 0 .t edit modified } {0} - test text-25.10 {TextEditCmd procedure, set modified flag} { catch {destroy .t} text .t @@ -1549,7 +3063,6 @@ test text-25.10.1 {TextEditCmd procedure, set modified flag repeat} { update idletasks lappend ::retval [.t edit modified] } {0 modified 1 1} - test text-25.11 {<<Modified>> virtual event} { set ::retval unmodified catch {destroy .t} @@ -1580,7 +3093,6 @@ test text-25.11.2 {<<Modified>> virtual event - delete before Modified} { .t delete 1.0 1.2 set ::retval } {thing special} - test text-25.12 {<<Selection>> virtual event} { set ::retval no_selection catch {destroy .t} @@ -1592,7 +3104,6 @@ test text-25.12 {<<Selection>> virtual event} { .t tag add sel 1.0 1.1 set ::retval } {selection_changed} - test text-25.13 {-maxundo configuration option} { catch {destroy .t} text .t -undo 1 -autoseparators 1 -maxundo 2 @@ -1605,19 +3116,15 @@ test text-25.13 {-maxundo configuration option} { catch {.t edit undo} .t get 1.0 end } "line 1\n\n" - -test text-25.14 {undo with space-based path} { - set t {.t e x t} - destroy $t - text $t -undo 1 - $t insert end "line 1\n" - $t delete 1.4 1.6 - $t insert end "line 2\n" - $t edit undo - $t edit undo - $t get 1.0 end -} "line 1\n\n" - +test text-25.15 {bug fix 1536735 - undo with empty text} { + catch {destroy .t} + text .t -undo 1 + set r [.t edit modified] + .t delete 1.0 + lappend r [.t edit modified] + lappend r [catch {.t edit undo}] + lappend r [.t edit modified] +} {0 0 1 0} test text-25.18 {patch 1469210 - inserting after undo} -setup { destroy .t } -body { @@ -1637,9 +3144,548 @@ test text-26.1 {bug fix - 624372, ControlUtfProc long lines} { .t insert end [string repeat "\1" 500] } {} +test text-27.1 {tabs - must be positive and must be increasing} { + destroy .t + pack [text .t -wrap none] + list [catch {.t configure -tabs {0}} msg] $msg +} {1 {tab stop "0" is not at a positive distance}} +test text-27.2 {tabs - must be positive and must be increasing} { + destroy .t + pack [text .t -wrap none] + list [catch {.t configure -tabs {-5}} msg] $msg +} {1 {tab stop "-5" is not at a positive distance}} +test text-27.3 {tabs - must be positive and must be increasing} {knownBug} { + # This bug will be fixed in Tk 9.0, when we can allow a minor + # incompatibility with Tk 8.x + destroy .t + pack [text .t -wrap none] + list [catch {.t configure -tabs {10c 5c}} msg] $msg +} {1 {tabs must be monotonically increasing, but "5c" is smaller than or equal to the previous tab}} +test text-27.4 {tabs - must be positive and must be increasing} { + destroy .t + pack [text .t -wrap none] + .t insert end "a\tb\tc\td\te" + catch {.t configure -tabs {10c 5c}} + update ; update ; update + # This test must simply not go into an infinite loop to succeed + set result 1 +} {1} + +test text-28.0 {repeated insert and scroll} { + foreach subcmd { + {moveto 1} + {scroll 1 pages} + {scroll 100 pixels} + {scroll 10 units} + } { + destroy .t + pack [text .t] + for {set i 0} {$i < 30} {incr i} { + .t insert end "blabla\n" + eval .t yview $subcmd + } + } + # This test must simply not crash to succeed + set result 1 +} {1} + +test text-29.0 {peer widgets} { + destroy .t .tt + toplevel .tt + pack [text .t] + pack [.t peer create .tt.t] + destroy .t .tt +} {} +test text-29.1 {peer widgets} { + destroy .t .t1 .t2 + toplevel .t1 + toplevel .t2 + pack [text .t] + pack [.t peer create .t1.t] + pack [.t peer create .t2.t] + .t insert end "abcd\nabcd" + update + destroy .t1 + update + .t insert end "abcd\nabcd" + update + destroy .t .t2 + update +} {} +test text-29.2 {peer widgets} { + destroy .t .t1 .t2 + toplevel .t1 + toplevel .t2 + pack [text .t] + pack [.t peer create .t1.t] + pack [.t peer create .t2.t] + .t insert end "abcd\nabcd" + update + destroy .t + update + .t2.t insert end "abcd\nabcd" + update + destroy .t .t2 + update +} {} +test text-29.3 {peer widgets} { + destroy .t .tt + toplevel .tt + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + pack [.t peer create .tt.t -start 5 -end 11] + update + destroy .t .tt +} {} +test text-29.4 {peer widgets} { + destroy .t .tt + toplevel .tt + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + pack [.t peer create .tt.t -start 5 -end 11] + pack [.tt.t peer create .tt.t2] + set res [list [.tt.t index end] [.tt.t2 index end]] + update + destroy .t .tt + set res +} {7.0 7.0} +test text-29.4.1 {peer widgets} { + destroy .t .tt + toplevel .tt + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + pack [.t peer create .tt.t -start 5 -end 11] + pack [.tt.t peer create .tt.t2 -start {} -end {}] + set res [list [.tt.t index end] [.tt.t2 index end]] + update + destroy .t .tt + set res +} {7.0 21.0} +test text-29.5 {peer widgets} { + destroy .t .tt + toplevel .tt + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + pack [.t peer create .tt.t -start 5 -end 11] + update ; update + set p1 [.tt.t count -update -ypixels 1.0 end] + set p2 [.t count -update -ypixels 5.0 11.0] + if {$p1 == $p2} { + set res "ok" + } else { + set res "$p1 and $p2 not equal" + } + destroy .t .tt + set res +} {ok} +test text-29.6 {peer widgets} { + destroy .t .tt + toplevel .tt + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + pack [.t peer create .tt.t -start 5 -end 11] + update ; update + .t delete 3.0 6.0 + set res [.tt.t index end] + destroy .t .tt + set res +} {6.0} +test text-29.7 {peer widgets} { + destroy .t .tt + toplevel .tt + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + pack [.t peer create .tt.t -start 5 -end 11] + update ; update + .t delete 8.0 12.0 + set res [.tt.t index end] + destroy .t .tt + set res +} {4.0} +test text-29.8 {peer widgets} { + destroy .t .tt + toplevel .tt + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + pack [.t peer create .tt.t -start 5 -end 11] + update ; update + .t delete 3.0 13.0 + set res [.tt.t index end] + destroy .t .tt + set res +} {1.0} +test text-29.9 {peer widgets} { + destroy .t + pack [text .t] + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + .t tag add sel 1.0 end-1c + set res {} + lappend res [.t tag ranges sel] + .t configure -start 10 -end 20 + lappend res [.t tag ranges sel] + destroy .t + set res +} {{1.0 100.0} {1.0 11.0}} +test text-29.10 {peer widgets} { + destroy .t + pack [text .t] + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + .t tag add sel 1.0 end-1c + set res {} + lappend res [.t tag ranges sel] + .t configure -start 11 + lappend res [.t tag ranges sel] + destroy .t + set res +} {{1.0 100.0} {1.0 90.0}} +test text-29.11 {peer widgets} { + destroy .t + pack [text .t] + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + .t tag add sel 1.0 end-1c + set res {} + lappend res [.t tag ranges sel] + .t configure -end 90 + lappend res [.t tag ranges sel] + destroy .t + set res +} {{1.0 100.0} {1.0 90.0}} +test text-29.12 {peer widgets} { + destroy .t + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + .t tag add sel 1.0 3.0 5.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 + set res {} + lappend res [.t tag prevrange sel 1.0] + .t configure -start 6 -end 12 + lappend res [.t tag ranges sel] + lappend res "next" [.t tag nextrange sel 4.0] \ + [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \ + [.t tag nextrange sel 7.0] + lappend res "prev" [.t tag prevrange sel 1.0] \ + [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \ + [.t tag prevrange sel 4.0] + destroy .t + set res +} {{} {1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}} +test text-29.13 {peer widgets} { + destroy .t + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + .t tag add sel 1.0 3.0 9.0 11.0 13.0 15.0 17.0 19.0 + set res {} + .t configure -start 6 -end 12 + lappend res [.t tag ranges sel] + lappend res "next" [.t tag nextrange sel 4.0] \ + [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \ + [.t tag nextrange sel 7.0] + lappend res "prev" [.t tag prevrange sel 1.0] \ + [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \ + [.t tag prevrange sel 4.0] + destroy .t + set res +} {{4.0 6.0} next {4.0 6.0} {} {} {} prev {} {} {} {}} +test text-29.14 {peer widgets} { + destroy .t + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + .t tag add sel 1.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 + set res {} + .t configure -start 6 -end 12 + lappend res [.t tag ranges sel] + lappend res "next" [.t tag nextrange sel 4.0] \ + [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \ + [.t tag nextrange sel 7.0] + lappend res "prev" [.t tag prevrange sel 1.0] \ + [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \ + [.t tag prevrange sel 4.0] + destroy .t + set res +} {{1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}} +test text-29.15 {peer widgets} { + destroy .t + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + set res {} + .t tag add sel 1.0 11.0 + lappend res [.t tag ranges sel] + lappend res [catch {.t configure -start 15 -end 10}] + lappend res [.t tag ranges sel] + .t configure -start 6 -end 12 + lappend res [.t tag ranges sel] + .t configure -start {} -end {} + lappend res [.t tag ranges sel] + destroy .t + set res +} {{1.0 11.0} 1 {1.0 11.0} {1.0 6.0} {1.0 11.0}} +test text-29.16 {peer widgets} { + destroy .t + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + set res {} + .t tag add sel 1.0 11.0 + lappend res [.t index sel.first] + lappend res [.t index sel.last] + destroy .t + set res +} {1.0 11.0} +test text-29.17 {peer widgets} { + destroy .t + pack [text .t] + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" + } + set res {} + .t tag delete sel + set res [list [catch {.t index sel.first} msg] $msg] + destroy .t + set res +} {1 {text doesn't contain any characters tagged with "sel"}} + +proc makeText {} { + set w .g + set font "Times 11" + destroy .g + toplevel .g + frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken + set t $w.f.text + text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \ + -height 35 -wrap word -highlightthickness 0 -borderwidth 0 + pack $t -expand yes -fill both + scrollbar $w.scroll -command "$t yview" + pack $w.scroll -side right -fill y + pack $w.f -expand yes -fill both + $t tag configure center -justify center -spacing1 5m -spacing3 5m + $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \ + -spacing1 3m -spacing2 0 -spacing3 0 + for {set i 0} {$i < 40} {incr i} { + $t insert end "${i}word " + } + return $t +} + +test text-30.1 {line heights on creation} { + set w [makeText] + update ; after 1000 ; update + set before [$w count -ypixels 1.0 2.0] + $w insert 1.0 "a" + update + set after [$w count -ypixels 1.0 2.0] + destroy .g + if {$before != $after} { + set res "Count changed: $before $after" + } else { + set res "ok" + } +} {ok} + +destroy .t +text .t +test text-31.1 {TextWidgetCmd procedure, "peer" option} { + list [catch {.t peer foo 1} msg] $msg +} {1 {bad peer option "foo": must be create or names}} +test text-31.2 {TextWidgetCmd procedure, "peer" option} { + list [catch {.t peer names foo} msg] $msg +} {1 {wrong # args: should be ".t peer names"}} +test text-31.3 {TextWidgetCmd procedure, "peer" option} { + list [catch {.t p names} msg] $msg +} {0 {}} +test text-31.4 {TextWidgetCmd procedure, "peer" option} { + .t peer names +} {} +test text-31.5 {TextWidgetCmd procedure, "peer" option} { + list [catch {.t peer create foo} msg] $msg +} {1 {bad window path name "foo"}} +test text-31.6 {TextWidgetCmd procedure, "peer" option} { + .t peer create .t2 + set res {} + lappend res [.t peer names] + lappend res [.t2 peer names] + destroy .t2 + lappend res [.t peer names] +} {.t2 .t {}} +test text-31.7 {peer widget -start, -end} { + set res [list [catch {.t configure -start 10 -end 5} msg] $msg] + .t configure -start {} -end {} + set res +} {0 {}} +test text-31.8 {peer widget -start, -end} { + .t delete 1.0 end + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + list [catch {.t configure -start 10 -end 5} msg] $msg +} {1 {-startline must be less than or equal to -endline}} +test text-31.9 {peer widget -start, -end} { + .t delete 1.0 end + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + set res [list [catch {.t configure -start 5 -end 10} msg] $msg] + .t configure -start {} -end {} + set res +} {0 {}} +test text-31.10 {peer widget -start, -end} { + .t delete 1.0 end + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + set res [.t index end] + lappend res [catch {.t configure -start 5 -end 10 -tab foo}] + lappend res [.t index end] + lappend res [catch {.t configure -tab foo -start 15 -end 20}] + lappend res [.t index end] + .t configure -start {} -end {} + lappend res [.t index end] + set res +} {101.0 1 101.0 1 101.0 101.0} +test text-31.11 {peer widget -start, -end} { + .t delete 1.0 end + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + set res [.t index end] + lappend res [catch {.t configure -start 5 -end 15}] + lappend res [.t index end] + lappend res [catch {.t configure -start 10 -end 40}] + lappend res [.t index end] + .t configure -start {} -end {} + lappend res [.t index end] + set res +} {101.0 0 11.0 0 31.0 101.0} + +test text-32.1 {peer widget -start, -end and selection} { + .t delete 1.0 end + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + .t tag add sel 10.0 20.0 + set res {} + lappend res [.t tag ranges sel] + .t configure -start 5 -end 30 + lappend res [.t tag ranges sel] + .t configure -start 5 -end 15 + lappend res [.t tag ranges sel] + .t configure -start 15 -end 30 + lappend res [.t tag ranges sel] + .t configure -start 15 -end 16 + lappend res [.t tag ranges sel] + .t configure -start 25 -end 30 + lappend res [.t tag ranges sel] + .t configure -start {} -end {} + lappend res [.t tag ranges sel] + set res +} {{10.0 20.0} {6.0 16.0} {6.0 11.0} {1.0 6.0} {1.0 2.0} {} {10.0 20.0}} + +test text-33.1 {widget dump -command alters tags} { + .t delete 1.0 end + .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c + .t tag configure b -background red + proc Dumpy {key value index} { + #puts "KK: $key, $value" + .t tag add $value [list $index linestart] [list $index lineend] + } + .t dump -all -command Dumpy 1.0 end + set result "ok" +} {ok} +test text-33.2 {widget dump -command makes massive changes} { + .t delete 1.0 end + .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c + .t tag configure b -background red + proc Dumpy {key value index} { + #puts "KK: $key, $value" + .t delete 1.0 end + } + .t dump -all -command Dumpy 1.0 end + set result "ok" +} {ok} +test text-33.3 {widget dump -command destroys widget} { + .t delete 1.0 end + .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c + .t tag configure b -background red + proc Dumpy {key value index} { + #puts "KK: $key, $value" + destroy .t + } + .t dump -all -command Dumpy 1.0 end + set result "ok" +} {ok} + deleteWindows option clear +test text-36.1 "bug #1777362: event handling with hyphenated windows" -setup { + proc bgerror {m} {set ::my_error $m} + set ::my_error {} + pack [set w [text .t-1]] +} -body { + tkwait visibility $w + event generate $w <1> + event generate $w <1> + update + set ::my_error +} -cleanup { + destroy .t-1 +} -result {} + +test text-36.2 "bug #1777362: event handling with hyphenated windows" -setup { + proc bgerror {m} {set ::my_error $m} + set ::my_error {} + pack [set w [text .t+1]] +} -body { + tkwait visibility $w + event generate $w <1> + event generate $w <1> + update + set ::my_error +} -cleanup { + destroy $w +} -result {} + +test text-36.3 "bug #1777362: event handling with hyphenated windows" -setup { + proc bgerror {m} {set ::my_error $m} + set ::my_error {} + pack [set w [text .t*1]] +} -body { + tkwait visibility $w + event generate $w <1> + event generate $w <1> + update + set ::my_error +} -cleanup { + destroy $w +} -result {} + # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/textBTree.test b/tests/textBTree.test index c3ae6e6..3a89e55 100644 --- a/tests/textBTree.test +++ b/tests/textBTree.test @@ -9,10 +9,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands catch {destroy .t} @@ -897,18 +894,5 @@ test btree-18.9 {tag search back, large complex btree spans} { destroy .t # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/textDisp.test b/tests/textDisp.test index 0b3d385..8e99eff 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -7,15 +7,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands - -namespace import -force tcltest::interpreter -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile +namespace import -force tcltest::test # The procedure below is used as the scrolling command for the text; # it just saves the scrolling information in a variable "scrollInfo". @@ -42,15 +36,33 @@ option add *Text.highlightThickness 2 # because some window managers don't allow the overall width of a window # to get very narrow. +catch {destroy .f .t} frame .f -width 100 -height 20 pack append . .f left set fixedFont {Courier -12} +# 15 on XP, 13 on Solaris 8 set fixedHeight [font metrics $fixedFont -linespace] +# 7 on all platforms set fixedWidth [font measure $fixedFont m] +# 12 on XP +set fixedAscent [font metrics $fixedFont -ascent] +set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP set varFont {Times -14} +# 16 on XP, 15 on Solaris 8 +set varHeight [font metrics $varFont -linespace] +# 13 on XP +set varAscent [font metrics $varFont -ascent] +set varDiff [expr {$varHeight - 15}] ;# 1 on XP + set bigFont {Helvetica -24} +# 27 on XP, 27 on Solaris 8 +set bigHeight [font metrics $bigFont -linespace] +# 21 on XP +set bigAscent [font metrics $bigFont -ascent] +set ascentDiff [expr {$bigAscent - $fixedAscent}] + text .t -font $fixedFont -width 20 -height 10 -yscrollcommand scroll pack append . .t {top expand fill} .t tag configure big -font $bigFont @@ -76,6 +88,106 @@ update if {([winfo rooty .] < 50) || ([winfo rootx .] < 50)} { wm geom . +50+50 } + +test textDisp-0.1 {double tag elide transition} { + # Example from tkchat crash. For some reason can only + # get this test case to crash when first. + catch {destroy .top} + pack [text .top] + + foreach val {0 1 2 3} { + .top insert 1.0 "hello\n" + .top tag configure tag$val + .top tag add tag$val 1.0 2.0 + set ::Options(tag$val) 0 + } + + proc DoVis {tag} { + .top tag config $tag -elide $::Options($tag) + } + + proc NickVis {val} { + foreach t [array names ::Options ] { + if {$::Options($t) != $val} { + set ::Options($t) $val + DoVis $t + } + } + } + NickVis 1 + unset ::Options + destroy .top +} {} + +test textDisp-0.2 {double tag elide transition} { + # Example from tkchat crash. For some reason can only + # get this test case to crash when first. + catch {destroy .top} + pack [text .top] + + foreach val {0 1 2 3} { + .top insert 1.0 "hello" + .top tag configure tag$val + .top tag add tag$val 1.0 1.5 + set ::Options(tag$val) 0 + } + + proc DoVis {tag} { + .top tag config $tag -elide $::Options($tag) + } + + proc NickVis {val} { + foreach t [array names ::Options ] { + if {$::Options($t) != $val} { + set ::Options($t) $val + DoVis $t + } + } + } + NickVis 1 + unset ::Options + destroy .top +} {} + +test textDisp-0.3 {double tag elide transition} { + catch {destroy .txt} + pack [text .txt] + # Note that TRAFFIC should have a higher priority than SYSTEM + # in terms of the tag effects. + .txt tag configure SYSTEM -elide 0 + .txt tag configure TRAFFIC -elide 1 + .txt insert end "\n" {TRAFFIC SYSTEM} + update + destroy .txt +} {} + +test textDisp-0.4 {double tag elide transition} { + catch {destroy .txt} + pack [text .txt] + # Note that TRAFFIC should have a higher priority than SYSTEM + # in terms of the tag effects. + .txt tag configure SYSTEM -elide 0 + .txt tag configure TRAFFIC -elide 1 + .txt insert end "\n" {SYSTEM TRAFFIC} + # Crash was here. + update + destroy .txt +} {} + +test textDisp-0.5 {double tag elide transition} { + catch {destroy .txt} + pack [text .txt] + .txt tag configure WELCOME -elide 1 + .txt tag configure SYSTEM -elide 0 + .txt tag configure TRAFFIC -elide 1 + + .txt insert end "\n" {SYSTEM TRAFFIC} + .txt insert end "\n" WELCOME + # Crash was here. + update + destroy .txt +} {} + test textDisp-1.1 {GetStyle procedure, priorities and tab stops} { .t delete 1.0 end .t insert 1.0 "x\ty" @@ -94,9 +206,9 @@ test textDisp-1.1 {GetStyle procedure, priorities and tab stops} { .t tag raise x update idletasks lappend x [lindex [.t bbox 1.2] 0] -} {75 55 55} +} [list 75 55 55] .t tag delete x y z -test textDisp-1.2 {GetStyle procedure, wrapmode} {fonts} { +test textDisp-1.2 {GetStyle procedure, wrapmode} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcd\nefg hijkl mnop qrstuv wxyz" @@ -109,7 +221,7 @@ test textDisp-1.2 {GetStyle procedure, wrapmode} {fonts} { lappend result [.t bbox 2.20] .t tag add y 1.end 2.2 lappend result [.t bbox 2.20] -} {{5 31 7 13} {40 31 7 13} {}} +} [list [list 5 [expr {5+2*$fixedHeight}] 7 $fixedHeight] [list 40 [expr {5+2*$fixedHeight}] 7 $fixedHeight] {}] .t tag delete x y test textDisp-2.1 {LayoutDLine, basics} { @@ -118,49 +230,49 @@ test textDisp-2.1 {LayoutDLine, basics} { .t insert 1.0 "This is some sample text for testing." list [.t bbox 1.19] [.t bbox 1.20] } [list [list [expr 5 + $fixedWidth * 19] 5 $fixedWidth $fixedHeight] [list 5 [expr 5 + $fixedHeight] $fixedWidth $fixedHeight]] -test textDisp-2.2 {LayoutDLine, basics} {fonts} { +test textDisp-2.2 {LayoutDLine, basics} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "This isx some sample text for testing." list [.t bbox 1.19] [.t bbox 1.20] -} {{138 5 7 13} {5 18 7 13}} -test textDisp-2.3 {LayoutDLine, basics} {fonts} { +} [list [list 138 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-2.3 {LayoutDLine, basics} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "This isxxx some sample text for testing." list [.t bbox 1.19] [.t bbox 1.20] -} {{138 5 7 13} {5 18 7 13}} -test textDisp-2.4 {LayoutDLine, word wrap} {fonts} { +} [list [list 138 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-2.4 {LayoutDLine, word wrap} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This is some sample text for testing." list [.t bbox 1.19] [.t bbox 1.20] -} {{138 5 7 13} {5 18 7 13}} -test textDisp-2.5 {LayoutDLine, word wrap} {fonts} { +} [list [list 138 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-2.5 {LayoutDLine, word wrap} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This isx some sample text for testing." list [.t bbox 1.13] [.t bbox 1.14] [.t bbox 1.19] -} {{96 5 49 13} {5 18 7 13} {40 18 7 13}} -test textDisp-2.6 {LayoutDLine, word wrap} {fonts} { +} [list [list 96 5 49 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 40 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-2.6 {LayoutDLine, word wrap} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This isxxx some sample text for testing." list [.t bbox 1.15] [.t bbox 1.16] -} {{110 5 35 13} {5 18 7 13}} -test textDisp-2.7 {LayoutDLine, marks and tags} {fonts} { +} [list [list 110 5 35 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-2.7 {LayoutDLine, marks and tags} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This isxxx some sample text for testing." .t tag add foo 1.4 1.6 .t mark set insert 1.8 list [.t bbox 1.2] [.t bbox 1.5] [.t bbox 1.11] -} {{19 5 7 13} {40 5 7 13} {82 5 7 13}} +} [list [list 19 5 7 $fixedHeight] [list 40 5 7 $fixedHeight] [list 82 5 7 $fixedHeight]] foreach m [.t mark names] { catch {.t mark unset $m} } scan [wm geom .] %dx%d width height -test textDisp-2.8 {LayoutDLine, extra chunk at end of dline} {fonts} { +test textDisp-2.8 {LayoutDLine, extra chunk at end of dline} {textfonts} { wm geom . [expr $width+1]x$height update .t configure -wrap char @@ -168,16 +280,16 @@ test textDisp-2.8 {LayoutDLine, extra chunk at end of dline} {fonts} { .t insert 1.0 "This isxx some sample text for testing." .t mark set foo 1.20 list [.t bbox 1.19] [.t bbox 1.20] -} {{138 5 8 13} {5 18 7 13}} +} [list [list 138 5 8 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] wm geom . {} update -test textDisp-2.9 {LayoutDLine, marks and tags} {fonts} { +test textDisp-2.9 {LayoutDLine, marks and tags} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This is a very_very_long_word_that_wraps." list [.t bbox 1.9] [.t bbox 1.10] [.t bbox 1.25] -} {{68 5 77 13} {5 18 7 13} {110 18 7 13}} -test textDisp-2.10 {LayoutDLine, marks and tags} {fonts} { +} [list [list 68 5 77 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 110 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-2.10 {LayoutDLine, marks and tags} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This is a very_very_long_word_that_wraps." @@ -186,14 +298,14 @@ test textDisp-2.10 {LayoutDLine, marks and tags} {fonts} { .t tag add foo 1.17 .t tag add foo 1.19 list [.t bbox 1.9] [.t bbox 1.10] [.t bbox 1.25] -} {{68 5 77 13} {5 18 7 13} {110 18 7 13}} -test textDisp-2.11 {LayoutDLine, newline width} {fonts} { +} [list [list 68 5 77 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 110 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-2.11 {LayoutDLine, newline width} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a\nbb\nccc\ndddd" list [.t bbox 2.2] [.t bbox 3.3] -} {{19 18 126 13} {26 31 119 13}} -test textDisp-2.12 {LayoutDLine, justification} {fonts} { +} [list [list 19 [expr {$fixedDiff + 18}] 126 $fixedHeight] [list 26 [expr {2*$fixedDiff + 31}] 119 $fixedHeight]] +test textDisp-2.12 {LayoutDLine, justification} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "\na\nbb\nccc\ndddd" @@ -201,8 +313,8 @@ test textDisp-2.12 {LayoutDLine, justification} {fonts} { .t tag add x 1.0 end .t tag add y 3.0 3.2 list [.t bbox 1.0] [.t bbox 2.0] [.t bbox 4.0] [.t bbox 4.2] -} {{75 5 70 13} {71 18 7 13} {64 44 7 13} {78 44 7 13}} -test textDisp-2.13 {LayoutDLine, justification} {fonts} { +} [list [list 75 5 70 $fixedHeight] [list 71 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 64 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] [list 78 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] +test textDisp-2.13 {LayoutDLine, justification} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "\na\nbb\nccc\ndddd" @@ -210,8 +322,8 @@ test textDisp-2.13 {LayoutDLine, justification} {fonts} { .t tag add x 1.0 end .t tag add y 3.0 3.2 list [.t bbox 1.0] [.t bbox 2.0] [.t bbox 4.0] [.t bbox 4.2] -} {{145 5 0 13} {138 18 7 13} {124 44 7 13} {138 44 7 13}} -test textDisp-2.14 {LayoutDLine, justification} {fonts} { +} [list [list 145 5 0 $fixedHeight] [list 138 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 124 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] [list 138 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] +test textDisp-2.14 {LayoutDLine, justification} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "\na\nbb\nccc\ndddd" @@ -221,8 +333,8 @@ test textDisp-2.14 {LayoutDLine, justification} {fonts} { .t tag add y 3.0 4.0 .t tag raise y list [.t bbox 2.0] [.t bbox 3.0] [.t bbox 3.end] [.t bbox 4.0] -} {{71 18 7 13} {131 31 7 13} {145 31 0 13} {5 44 7 13}} -test textDisp-2.15 {LayoutDLine, justification} {fonts} { +} [list [list 71 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 131 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 145 [expr {2*$fixedDiff + 31}] 0 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] +test textDisp-2.15 {LayoutDLine, justification} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "\na\nbb\nccc\ndddd" @@ -232,8 +344,8 @@ test textDisp-2.15 {LayoutDLine, justification} {fonts} { .t tag add y 3.0 4.0 .t tag lower y list [.t bbox 2.0] [.t bbox 3.0] [.t bbox 3.end] [.t bbox 4.0] -} {{71 18 7 13} {68 31 7 13} {82 31 63 13} {5 44 7 13}} -test textDisp-2.16 {LayoutDLine, justification} {fonts} { +} [list [list 71 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 68 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 82 [expr {2*$fixedDiff + 31}] 63 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] +test textDisp-2.16 {LayoutDLine, justification} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines" @@ -241,16 +353,16 @@ test textDisp-2.16 {LayoutDLine, justification} {fonts} { .t tag add x 1.1 1.20 .t tag add x 1.21 1.end list [.t bbox 1.0] [.t bbox 1.20] [.t bbox 1.36] [.t bbox 2.0] -} {{5 5 7 13} {5 18 7 13} {43 31 7 13} {5 44 7 13}} -test textDisp-2.17 {LayoutDLine, justification} {fonts} { +} [list [list 5 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 43 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] +test textDisp-2.17 {LayoutDLine, justification} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines" .t tag configure x -justify center .t tag add x 1.20 list [.t bbox 1.0] [.t bbox 1.20] [.t bbox 1.36] [.t bbox 2.0] -} {{5 5 7 13} {19 18 7 13} {5 31 7 13} {5 44 7 13}} -test textDisp-2.18 {LayoutDLine, justification} {fonts} { +} [list [list 5 5 7 $fixedHeight] [list 19 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] +test textDisp-2.18 {LayoutDLine, justification} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to extend out of the window\n" @@ -261,18 +373,18 @@ test textDisp-2.18 {LayoutDLine, justification} {fonts} { .t tag add y 3.0 .t xview scroll 5 units list [.t bbox 2.0] [.t bbox 3.0] -} {{26 18 7 13} {40 31 7 13}} +} [list [list 26 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 40 [expr {2*$fixedDiff + 31}] 7 $fixedHeight]] .t tag delete x .t tag delete y -test textDisp-2.19 {LayoutDLine, margins} {fonts} { +test textDisp-2.19 {LayoutDLine, margins} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines" .t tag configure x -lmargin1 20 -lmargin2 40 -rmargin 15 .t tag add x 1.0 end list [.t bbox 1.0] [.t bbox 1.12] [.t bbox 1.13] [.t bbox 2.0] -} {{25 5 7 13} {109 5 36 13} {45 18 7 13} {25 70 7 13}} -test textDisp-2.20 {LayoutDLine, margins} {fonts} { +} [list [list 25 5 7 $fixedHeight] [list 109 5 36 $fixedHeight] [list 45 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 25 [expr {5*$fixedDiff + 70}] 7 $fixedHeight]] +test textDisp-2.20 {LayoutDLine, margins} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines" @@ -282,18 +394,18 @@ test textDisp-2.20 {LayoutDLine, margins} {fonts} { .t tag add x 1.0 end .t tag add y 1.13 list [.t bbox 1.0] [.t bbox 1.13] [.t bbox 1.30] [.t bbox 2.0] -} {{25 5 7 13} {10 18 7 13} {15 31 7 13} {25 44 7 13}} -test textDisp-2.21 {LayoutDLine, margins} {fonts} { +} [list [list 25 5 7 $fixedHeight] [list 10 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 15 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 25 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] +test textDisp-2.21 {LayoutDLine, margins} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Sample text" .t tag configure x -lmargin1 80 -lmargin2 80 -rmargin 100 .t tag add x 1.0 end list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 1.2] -} {{85 5 60 13} {85 18 60 13} {85 31 60 13}} +} [list [list 85 5 60 $fixedHeight] [list 85 [expr {$fixedDiff + 18}] 60 $fixedHeight] [list 85 [expr {2*$fixedDiff + 31}] 60 $fixedHeight]] .t tag delete x .t tag delete y -test textDisp-2.22 {LayoutDLine, spacing options} {fonts} { +test textDisp-2.22 {LayoutDLine, spacing options} {textfonts} { .t configure -wrap word .t delete 1.0 end .t tag delete x y @@ -318,9 +430,9 @@ test textDisp-2.22 {LayoutDLine, spacing options} {fonts} { set i [.t dlineinfo 3.0] set b4 [expr [lindex $i 1] + [lindex $i 4] - $b4] list $b1 $b2 $b3 $b4 -} {2 7 10 15} +} [list 2 7 10 15] .t configure -spacing1 0 -spacing2 0 -spacing3 0 -test textDisp-2.23 {LayoutDLine, spacing options} {fonts} { +test textDisp-2.23 {LayoutDLine, spacing options} {textfonts} { .t configure -wrap word .t delete 1.0 end .t tag delete x y @@ -350,9 +462,9 @@ test textDisp-2.23 {LayoutDLine, spacing options} {fonts} { set i [.t dlineinfo 3.0] set b4 [expr [lindex $i 1] + [lindex $i 4] - $b4] list $b1 $b2 $b3 $b4 -} {1 5 13 16} +} [list 1 5 13 16] .t configure -spacing1 0 -spacing2 0 -spacing3 0 -test textDisp-2.24 {LayoutDLine, tabs, saving from first chunk} {fonts} { +test textDisp-2.24 {LayoutDLine, tabs, saving from first chunk} {textfonts} { .t delete 1.0 end .t tag delete x y .t tag configure x -tabs 70 @@ -362,53 +474,53 @@ test textDisp-2.24 {LayoutDLine, tabs, saving from first chunk} {fonts} { .t tag add y 1.1 end lindex [.t bbox 1.3] 0 } {75} -test textDisp-2.25 {LayoutDLine, tabs, breaking chunks at tabs} {fonts} { +test textDisp-2.25 {LayoutDLine, tabs, breaking chunks at tabs} {textfonts} { .t delete 1.0 end .t tag delete x - .t tag configure x -tabs {30 60 90 120} + .t tag configure x -tabs [list 30 60 90 120] .t insert 1.0 "a\tb\tc\td\te" .t mark set dummy1 1.1 .t mark set dummy2 1.2 .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] \ [lindex [.t bbox 1.6] 0] [lindex [.t bbox 1.8] 0] -} {35 65 95 125} -test textDisp-2.26 {LayoutDLine, tabs, breaking chunks at tabs} {fonts} { +} [list 35 65 95 125] +test textDisp-2.26 {LayoutDLine, tabs, breaking chunks at tabs} {textfonts} { .t delete 1.0 end .t tag delete x - .t tag configure x -tabs {30 60 90 120} -justify right + .t tag configure x -tabs [list 30 60 90 120] -justify right .t insert 1.0 "a\tb\tc\td\te" .t mark set dummy1 1.1 .t mark set dummy2 1.2 .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] \ [lindex [.t bbox 1.6] 0] [lindex [.t bbox 1.8] 0] -} {117 124 131 138} -test textDisp-2.27 {LayoutDLine, tabs, calling AdjustForTab} {fonts} { +} [list 117 124 131 138] +test textDisp-2.27 {LayoutDLine, tabs, calling AdjustForTab} {textfonts} { .t delete 1.0 end .t tag delete x - .t tag configure x -tabs {30 60} + .t tag configure x -tabs [list 30 60] .t insert 1.0 "a\tb\tcd" .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] -} {35 65} -test textDisp-2.28 {LayoutDLine, tabs, running out of space in dline} {fonts} { +} [list 35 65] +test textDisp-2.28 {LayoutDLine, tabs, running out of space in dline} {textfonts} { .t delete 1.0 end .t insert 1.0 "a\tb\tc\td" .t bbox 1.6 -} {5 18 7 13} -test textDisp-2.29 {LayoutDLine, tabs, running out of space in dline} {fonts} { +} [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] +test textDisp-2.29 {LayoutDLine, tabs, running out of space in dline} {textfonts} { .t delete 1.0 end .t insert 1.0 "a\tx\tabcd" .t bbox 1.4 -} {117 5 7 13} -test textDisp-2.30 {LayoutDLine, tabs, running out of space in dline} {fonts} { +} [list 117 5 7 $fixedHeight] +test textDisp-2.30 {LayoutDLine, tabs, running out of space in dline} {textfonts} { .t delete 1.0 end .t insert 1.0 "a\tx\tabc" .t bbox 1.4 -} {117 5 7 13} +} [list 117 5 7 $fixedHeight] -test textDisp-3.1 {different character sizes} {fonts} { +test textDisp-3.1 {different character sizes} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert end "Some sample text, including both large\n" @@ -417,10 +529,9 @@ test textDisp-3.1 {different character sizes} {fonts} { .t tag add big 1.5 1.10 .t tag add big 2.11 2.14 list [.t bbox 1.1] [.t bbox 1.6] [.t dlineinfo 1.0] [.t dlineinfo 3.0] -} {{12 17 7 13} {52 5 13 27} {5 5 114 27 22} {5 85 35 13 10}} - +} [list [list 12 [expr {5+$ascentDiff}] 7 $fixedHeight] [list 52 5 13 27] [list 5 5 114 27 [font metrics $bigFont -ascent]] [list 5 [expr {2* $fixedDiff + 85}] 35 $fixedHeight [expr {$fixedDiff + 10}]]] .t configure -wrap char -test textDisp-4.1 {UpdateDisplayInfo, basic} {fonts} { +test textDisp-4.1 {UpdateDisplayInfo, basic} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2\nLine 3\n" update @@ -428,8 +539,8 @@ test textDisp-4.1 {UpdateDisplayInfo, basic} {fonts} { .t insert 2.0 "New Line 2" update list [.t bbox 1.0] [.t bbox 2.0] [.t bbox 3.0] $tk_textRelayout -} {{5 5 7 13} {5 18 7 13} {5 31 7 13} 2.0} -test textDisp-4.2 {UpdateDisplayInfo, re-use tail of text line} {fonts} { +} [list [list 5 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] 2.0] +test textDisp-4.2 {UpdateDisplayInfo, re-use tail of text line} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update @@ -438,8 +549,8 @@ test textDisp-4.2 {UpdateDisplayInfo, re-use tail of text line} {fonts} { .t insert 2.0 X update list [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout -} {{5 18 7 13} {12 31 7 13} {5 44 7 13} {2.0 2.20}} -test textDisp-4.3 {UpdateDisplayInfo, tail of text line shifts} {fonts} { +} [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 12 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}] +test textDisp-4.3 {UpdateDisplayInfo, tail of text line shifts} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update @@ -447,16 +558,19 @@ test textDisp-4.3 {UpdateDisplayInfo, tail of text line shifts} {fonts} { .t delete 2.2 update list [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout -} {{5 18 7 13} {5 31 7 13} {5 44 7 13} {2.0 2.20}} +} [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}] .t mark unset x -test textDisp-4.4 {UpdateDisplayInfo, wrap-mode "none"} {fonts} { +test textDisp-4.4 {UpdateDisplayInfo, wrap-mode "none"} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update list [.t bbox 2.0] [.t bbox 2.25] [.t bbox 3.0] $tk_textRelayout -} {{5 18 7 13} {} {5 31 7 13} {1.0 2.0 3.0}} -test textDisp-4.5 {UpdateDisplayInfo, tiny window} {fonts} { +} [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] {} [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] {1.0 2.0 3.0}] +test textDisp-4.5 {UpdateDisplayInfo, tiny window} {textfonts} { + if {$tcl_platform(platform) == "windows"} { + wm overrideredirect . 1 + } wm geom . 103x$height update .t configure -wrap none @@ -464,7 +578,10 @@ test textDisp-4.5 {UpdateDisplayInfo, tiny window} {fonts} { .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update list [.t bbox 2.0] [.t bbox 2.1] [.t bbox 3.0] $tk_textRelayout -} {{5 18 1 13} {} {5 31 1 13} {1.0 2.0 3.0}} +} [list [list 5 [expr {$fixedDiff + 18}] 1 $fixedHeight] {} [list 5 [expr {2*$fixedDiff + 31}] 1 $fixedHeight] {1.0 2.0 3.0}] +if {$tcl_platform(platform) == "windows"} { + wm overrideredirect . 0 +} test textDisp-4.6 {UpdateDisplayInfo, tiny window} { # This test was failing on Windows because the title bar on . # was a certain minimum size and it was interfering with the size @@ -488,7 +605,7 @@ test textDisp-4.6 {UpdateDisplayInfo, tiny window} { wm overrideredirect . 0 update set x -} {{5 5 1 1} {} 1.0} +} [list [list 5 5 1 1] {} 1.0] catch {destroy .f2} .t configure -borderwidth 0 -wrap char wm geom . {} @@ -524,14 +641,14 @@ test textDisp-4.8 {UpdateDisplayInfo, filling in extra vertical space} { update set x [list [.t index @0,0] $tk_textRelayout $tk_textRedraw] } {1.0 {5.0 4.0 3.0 2.0 1.0} {1.0 2.0 3.0 4.0 5.0 eof}} -test textDisp-4.9 {UpdateDisplayInfo, filling in extra vertical space} {fonts} { +test textDisp-4.9 {UpdateDisplayInfo, filling in extra vertical space} {textfonts} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview 16.0 update .t delete 15.0 end list [.t bbox 7.0] [.t bbox 12.0] -} {{3 29 7 13} {3 94 7 13}} +} [list [list 3 [expr {2*$fixedDiff + 29}] 7 $fixedHeight] [list 3 [expr {7*$fixedDiff + 94}] 7 $fixedHeight]] test textDisp-4.10 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" @@ -552,7 +669,7 @@ test textDisp-4.11 {UpdateDisplayInfo, filling in extra vertical space} { } {6.40 {13.0 7.0 6.80 6.60 6.40} {6.40 6.60 6.80 7.0 13.0}} test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end - .t insert end "1\n2\n3\n4\n5\n7\n8\n9\n10\n11\n12\n13" + .t insert end "1\n2\n3\n4\n5\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16" button .b -text "Test" -bd 2 -highlightthickness 2 .t window create 3.end -window .b .t yview moveto 1 @@ -602,7 +719,7 @@ test textDisp-4.16 {UpdateDisplayInfo, special handling for top/bottom lines} { update list $tk_textRelayout $tk_textRedraw } {{2.0 3.0} {2.0 3.0}} -test textDisp-4.17 {UpdateDisplayInfo, horizontal scrolling} {fonts} { +test textDisp-4.17 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" @@ -612,8 +729,8 @@ test textDisp-4.17 {UpdateDisplayInfo, horizontal scrolling} {fonts} { update list $tk_textRelayout $tk_textRedraw [.t bbox 2.0] [.t bbox 2.5] \ [.t bbox 2.23] -} {{} {1.0 2.0 3.0 4.0} {} {17 16 7 13} {}} -test textDisp-4.18 {UpdateDisplayInfo, horizontal scrolling} {fonts} { +} [list {} {1.0 2.0 3.0 4.0} {} [list 17 [expr {$fixedDiff + 16}] 7 $fixedHeight] {}] +test textDisp-4.18 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" @@ -622,8 +739,8 @@ test textDisp-4.18 {UpdateDisplayInfo, horizontal scrolling} {fonts} { .t xview scroll 100 units update list $tk_textRelayout $tk_textRedraw [.t bbox 2.25] -} {{} {1.0 2.0 3.0 4.0} {10 16 7 13}} -test textDisp-4.19 {UpdateDisplayInfo, horizontal scrolling} {fonts} { +} [list {} {1.0 2.0 3.0 4.0} [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-4.19 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" @@ -633,8 +750,8 @@ test textDisp-4.19 {UpdateDisplayInfo, horizontal scrolling} {fonts} { .t xview scroll -10 units update list $tk_textRelayout $tk_textRedraw [.t bbox 2.5] -} {{} {1.0 2.0 3.0 4.0} {38 16 7 13}} -test textDisp-4.20 {UpdateDisplayInfo, horizontal scrolling} {fonts} { +} [list {} {1.0 2.0 3.0 4.0} [list 38 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-4.20 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" @@ -645,8 +762,8 @@ test textDisp-4.20 {UpdateDisplayInfo, horizontal scrolling} {fonts} { .t delete 2.30 2.44 update list $tk_textRelayout $tk_textRedraw [.t bbox 2.25] -} {2.0 {1.0 2.0 3.0 4.0} {108 16 7 13}} -test textDisp-4.21 {UpdateDisplayInfo, horizontal scrolling} {fonts} { +} [list 2.0 {1.0 2.0 3.0 4.0} [list 108 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-4.21 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" @@ -657,7 +774,7 @@ test textDisp-4.21 {UpdateDisplayInfo, horizontal scrolling} {fonts} { update list $tk_textRelayout $tk_textRedraw } {{} {}} -test textDisp-4.22 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {fonts} { +test textDisp-4.22 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" @@ -666,8 +783,8 @@ test textDisp-4.22 {UpdateDisplayInfo, no horizontal scrolling except for -wrap update .t configure -wrap word list [.t bbox 2.0] [.t bbox 2.16] -} {{3 16 7 13} {10 29 7 13}} -test textDisp-4.23 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {fonts} { +} [list [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 10 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]] +test textDisp-4.23 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" @@ -676,9 +793,8 @@ test textDisp-4.23 {UpdateDisplayInfo, no horizontal scrolling except for -wrap update .t configure -wrap char list [.t bbox 2.0] [.t bbox 2.16] -} {{3 16 7 13} {115 16 7 13}} - -test textDisp-5.1 {DisplayDLine, handling of spacing} {fonts} { +} [list [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 115 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-5.1 {DisplayDLine, handling of spacing} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz" @@ -695,7 +811,7 @@ test textDisp-5.1 {DisplayDLine, handling of spacing} {fonts} { update list [winfo geometry .t.f1] [winfo geometry .t.f2] \ [winfo geometry .t.f3] [winfo geometry .t.f4] -} {10x4+24+11 10x4+55+15 10x4+10+43 10x4+76+40} +} [list 10x4+24+11 10x4+55+[expr {$fixedDiff/2 + 15}] 10x4+10+[expr {2*$fixedDiff + 43}] 10x4+76+[expr {2*$fixedDiff + 40}]] .t tag delete spacing # Although the following test produces a useful result, its main @@ -709,7 +825,7 @@ test textDisp-5.2 {DisplayDLine, line resizes during display} { .t window create insert -window .t.f update list [winfo width .t.f] [winfo height .t.f] -} {30 30} +} [list 30 30] .t configure -wrap char test textDisp-6.1 {scrolling in DisplayText, scroll up} { @@ -775,7 +891,7 @@ test textDisp-6.5 {scrolling in DisplayText, scroll source obscured} {nonPortabl destroy .f2 list $tk_textRelayout $tk_textRedraw } {{1.0 9.0 10.0} {1.0 4.0 5.0 9.0 10.0}} -test textDisp-6.6 {scrolling in DisplayText, Expose events after scroll} {unixOnly nonPortable} { +test textDisp-6.6 {scrolling in DisplayText, Expose events after scroll} {unix nonPortable} { # this test depends on all of the expose events being handled at once .t configure -wrap char frame .f2 -bg #ff0000 @@ -796,9 +912,9 @@ test textDisp-6.6 {scrolling in DisplayText, Expose events after scroll} {unixOn test textDisp-6.7 {DisplayText, vertical scrollbar updates} { .t configure -wrap char .t delete 1.0 end - update + update ; .t count -update -ypixels 1.0 end ; update set scrollInfo -} {0 1} +} {0.0 1.0} test textDisp-6.8 {DisplayText, vertical scrollbar updates} { .t configure -wrap char .t delete 1.0 end @@ -808,9 +924,9 @@ test textDisp-6.8 {DisplayText, vertical scrollbar updates} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { .t insert end "\nLine $i" } - update + update ; .t count -update -ypixels 1.0 end ; update set scrollInfo -} {0 0.769231} +} [list 0.0 [expr {10.0/13}]] .t configure -yscrollcommand {} -xscrollcommand scroll test textDisp-6.9 {DisplayText, horizontal scrollbar updates} { .t configure -wrap none @@ -822,7 +938,7 @@ test textDisp-6.9 {DisplayText, horizontal scrollbar updates} { .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx update set scrollInfo -} {0 0.363636} +} [list 0.0 [expr {4.0/11}]] # The following group of tests is marked non-portable because # they result in a lot of extra redisplay under Ultrix. I don't @@ -907,7 +1023,7 @@ test textDisp-7.8 {TkTextRedrawRegion} {nonPortable} { } {{} {borders 4.0 5.0 6.0 7.0 eof}} .t configure -bd 0 -test textDisp-8.1 {TkTextChanged: redisplay whole lines} {fonts} { +test textDisp-8.1 {TkTextChanged: redisplay whole lines} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around, two times" @@ -918,7 +1034,7 @@ test textDisp-8.1 {TkTextChanged: redisplay whole lines} {fonts} { .t delete 2.36 2.38 update list $tk_textRelayout $tk_textRedraw [.t bbox 2.32] -} {{2.0 2.18 2.38} {2.0 2.18 2.38} {101 29 7 13}} +} [list {2.0 2.18 2.38} {2.0 2.18 2.38} [list 101 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]] .t configure -wrap char test textDisp-8.2 {TkTextChanged, redisplay whole lines} { .t delete 1.0 end @@ -1025,10 +1141,12 @@ test textDisp-8.11 {TkTextChanged, scrollbar notification when changes are off-s update set scrollInfo "" .t insert end "a\nb\nc\n" - update + # We need to wait for our asychronous callbacks to update the + # scrollbar + update ; .t count -update -ypixels 1.0 end ; update .t configure -yscrollcommand "" set scrollInfo -} {0 0.625} +} {0.0 0.625} test textDisp-9.1 {TkTextRedrawTag} { .t configure -wrap char @@ -1039,7 +1157,7 @@ test textDisp-9.1 {TkTextRedrawTag} { update list $tk_textRelayout $tk_textRedraw } {{2.0 2.18} {2.0 2.18}} -test textDisp-9.2 {TkTextRedrawTag} {fonts} { +test textDisp-9.2 {TkTextRedrawTag} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" @@ -1098,7 +1216,7 @@ test textDisp-9.7 {TkTextRedrawTag} { update set tk_textRedraw } {2.0 2.20 eof} -test textDisp-9.8 {TkTextRedrawTag} {fonts} { +test textDisp-9.8 {TkTextRedrawTag} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" @@ -1108,7 +1226,7 @@ test textDisp-9.8 {TkTextRedrawTag} {fonts} { update set tk_textRedraw } {2.0 2.17} -test textDisp-9.9 {TkTextRedrawTag} {fonts} { +test textDisp-9.9 {TkTextRedrawTag} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" @@ -1150,6 +1268,7 @@ test textDisp-10.1 {TkTextRelayoutWindow} { list $tk_textRelayout $tk_textRedraw } {{1.0 2.0 2.20 3.0 3.20 4.0} {borders 1.0 2.0 2.20 3.0 3.20 4.0 eof}} .t configure -bg [lindex [.t configure -bg] 3] +catch {destroy .top} test textDisp-10.2 {TkTextRelayoutWindow} { toplevel .top -width 300 -height 200 wm geometry .top +0+0 @@ -1214,12 +1333,12 @@ test textDisp-11.6 {TkTextSetYView} { } {28.0 {28.0 29.0}} test textDisp-11.7 {TkTextSetYView} { .t yview 30.0 - update + update ; update set tk_textRedraw {} .t yview -pickplace 26.0 update list [.t index @0,0] $tk_textRedraw -} {22.0 {22.0 23.0 24.0 25.0 26.0 27.0 28.0 29.0}} +} {21.0 {21.0 22.0 23.0 24.0 25.0 26.0 27.0 28.0 29.0}} test textDisp-11.8 {TkTextSetYView} { .t yview 30.0 update @@ -1235,7 +1354,7 @@ test textDisp-11.9 {TkTextSetYView} { .t yview -pickplace 43.0 update list [.t index @0,0] $tk_textRedraw -} {39.0 {40.0 41.0 42.0 43.0 44.0 45.0 46.0 47.0 48.0}} +} {38.0 {40.0 41.0 42.0 43.0 44.0 45.0 46.0 47.0 48.0}} test textDisp-11.10 {TkTextSetYView} { .t yview 30.0 update @@ -1262,7 +1381,7 @@ test textDisp-11.12 {TkTextSetYView, wrapped line is off-screen} { list [.t index @0,0] $tk_textRedraw } {2.0 10.20} .t delete 10.0 11.0 -test textDisp-11.13 {TkTestSetYView, partially-visible last line} { +test textDisp-11.13 {TkTestSetYView, partially visible last line} { catch {destroy .top} toplevel .top wm geometry .top +0+0 @@ -1281,8 +1400,10 @@ test textDisp-11.13 {TkTestSetYView, partially-visible last line} { set tk_textRedraw {} .top.t see 5.0 update + # Note, with smooth scrolling, the results of this test + # have changed, and the old '2.0 {5.0 6.0}' is quite wrong. list [.top.t index @0,0] $tk_textRedraw -} {2.0 {5.0 6.0}} +} {1.0 5.0} catch {destroy .top} toplevel .top wm geometry .top +0+0 @@ -1304,7 +1425,8 @@ test textDisp-11.15 {TkTextSetYView, only a few lines visible} { update .top.t see 11.0 .top.t index @0,0 -} {10.0} + # Thie index 9.0 should be just visible by a couple of pixels +} {9.0} test textDisp-11.16 {TkTextSetYView, only a few lines visible} { .top.t yview 8.0 update @@ -1316,7 +1438,8 @@ test textDisp-11.17 {TkTextSetYView, only a few lines visible} { update .top.t see 4.0 .top.t index @0,0 -} {3.0} + # Thie index 2.0 should be just visible by a couple of pixels +} {2.0} destroy .top .t configure -wrap word @@ -1328,21 +1451,21 @@ test textDisp-12.1 {MeasureUp} { .t yview -pickplace 52.0 update .t index @0,0 -} {50.0} +} {49.0} test textDisp-12.2 {MeasureUp} { .t yview 100.0 update .t yview -pickplace 53.0 update .t index @0,0 -} {50.15} +} {50.0} test textDisp-12.3 {MeasureUp} { .t yview 100.0 update .t yview -pickplace 50.10 update .t index @0,0 -} {46.0} +} {45.0} .t configure -wrap none test textDisp-12.4 {MeasureUp} { .t yview 100.0 @@ -1350,14 +1473,14 @@ test textDisp-12.4 {MeasureUp} { .t yview -pickplace 53.0 update .t index @0,0 -} {49.0} +} {48.0} test textDisp-12.5 {MeasureUp} { .t yview 100.0 update .t yview -pickplace 50.10 update .t index @0,0 -} {46.0} +} {45.0} .t configure -wrap none .t delete 1.0 end @@ -1399,14 +1522,16 @@ test textDisp-13.6 {TkTextSeeCmd procedure} { set x [.t index @0,0] .t configure -wrap none set x -} {28.0} -test textDisp-13.7 {TkTextSeeCmd procedure} {fonts} { +} {27.0} +test textDisp-13.7 {TkTextSeeCmd procedure} {textfonts} { .t xview moveto 0 .t yview moveto 0 .t tag add sel 30.20 .t tag add sel 30.40 update .t see 30.50 + .t yview 25.0 + .t see 30.50 set x [list [.t bbox 30.50]] .t see 30.39 lappend x [.t bbox 30.39] @@ -1414,8 +1539,8 @@ test textDisp-13.7 {TkTextSeeCmd procedure} {fonts} { lappend x [.t bbox 30.38] .t see 30.20 lappend x [.t bbox 30.20] -} {{73 55 7 13} {3 55 7 13} {3 55 7 13} {73 55 7 13}} -test textDisp-13.8 {TkTextSeeCmd procedure} {fonts} { +} [list [list 73 [expr {5*$fixedDiff + 68}] 7 $fixedHeight] [list 3 [expr {5*$fixedDiff + 68}] 7 $fixedHeight] [list 3 [expr {5*$fixedDiff + 68}] 7 $fixedHeight] [list 73 [expr {5*$fixedDiff + 68}] 7 $fixedHeight]] +test textDisp-13.8 {TkTextSeeCmd procedure} {textfonts} { .t xview moveto 0 .t yview moveto 0 .t tag add sel 30.20 @@ -1429,8 +1554,8 @@ test textDisp-13.8 {TkTextSeeCmd procedure} {fonts} { lappend x [.t bbox 30.65] .t see 30.90 lappend x [.t bbox 30.90] -} {{73 55 7 13} {136 55 7 13} {136 55 7 13} {73 55 7 13}} -test textDisp-13.9 {TkTextSeeCmd procedure} {fonts} { +} [list [list 73 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 136 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 136 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 73 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight]] +test textDisp-13.9 {TkTextSeeCmd procedure} {textfonts} { wm geom . [expr $width-2]x$height .t xview moveto 0 .t yview moveto 0 @@ -1445,7 +1570,7 @@ test textDisp-13.9 {TkTextSeeCmd procedure} {fonts} { lappend x [.t bbox 30.65] .t see 30.90 lappend x [.t bbox 30.90] -} {{80 55 7 13} {136 55 7 13} {136 55 7 13} {80 55 7 13}} +} [list [list 74 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight] [list 138 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight] [list 138 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight] [list 74 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight]] test textDisp-13.10 {TkTextSeeCmd procedure} {} { # SF Bug 641778 set w .tsee @@ -1468,7 +1593,7 @@ test textDisp-14.1 {TkTextXviewCmd procedure} { .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto .5 .t xview -} {0.5 0.857143} +} [list 0.5 [expr {6./7.}]] .t configure -wrap char test textDisp-14.2 {TkTextXviewCmd procedure} { .t delete 1.0 end @@ -1477,7 +1602,7 @@ test textDisp-14.2 {TkTextXviewCmd procedure} { .t insert end "xxxxx\n" .t insert end "xxxx" .t xview -} {0 1} +} {0.0 1.0} .t configure -wrap none test textDisp-14.3 {TkTextXviewCmd procedure} { .t delete 1.0 end @@ -1486,7 +1611,7 @@ test textDisp-14.3 {TkTextXviewCmd procedure} { .t insert end "xxxxx\n" .t insert end "xxxx" .t xview -} {0 1} +} {0.0 1.0} test textDisp-14.4 {TkTextXviewCmd procedure} { list [catch {.t xview moveto} msg] $msg } {1 {wrong # args: should be ".t xview moveto fraction"}} @@ -1503,7 +1628,7 @@ test textDisp-14.7 {TkTextXviewCmd procedure} { .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto .3 .t xview -} {0.303571 0.660714} +} [list [expr {118.0/392}] [expr {258.0/392}]] test textDisp-14.8 {TkTextXviewCmd procedure} { .t delete 1.0 end .t insert end xxxxxxxxx\n @@ -1511,7 +1636,7 @@ test textDisp-14.8 {TkTextXviewCmd procedure} { .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto -.4 .t xview -} {0 0.357143} +} [list 0.0 [expr {5.0/14}]] test textDisp-14.9 {TkTextXviewCmd procedure} { .t delete 1.0 end .t insert end xxxxxxxxx\n @@ -1519,13 +1644,13 @@ test textDisp-14.9 {TkTextXviewCmd procedure} { .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview m 1.4 .t xview -} {0.642857 1} +} [list [expr {9.0/14}] 1.0] test textDisp-14.10 {TkTextXviewCmd procedure} { list [catch {.t xview scroll a} msg] $msg -} {1 {wrong # args: should be ".t xview scroll number units|pages"}} +} {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}} test textDisp-14.11 {TkTextXviewCmd procedure} { list [catch {.t xview scroll a b c} msg] $msg -} {1 {wrong # args: should be ".t xview scroll number units|pages"}} +} {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}} test textDisp-14.12 {TkTextXviewCmd procedure} { list [catch {.t xview scroll gorp units} msg] $msg } {1 {expected integer but got "gorp"}} @@ -1535,9 +1660,9 @@ test textDisp-14.13 {TkTextXviewCmd procedure} { .t insert end "a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto 0 - .t xview scroll 2 p + .t xview scroll 2 pa set x [.t index @0,22] - .t xview scroll -1 p + .t xview scroll -1 pa lappend x [.t index @0,22] .t xview scroll -2 pages lappend x [.t index @0,22] @@ -1559,10 +1684,10 @@ test textDisp-14.14 {TkTextXviewCmd procedure} { } {2.21 2.20 2.99 2.84} test textDisp-14.15 {TkTextXviewCmd procedure} { list [catch {.t xview scroll 14 globs} msg] $msg -} {1 {bad argument "globs": must be units or pages}} +} {1 {bad argument "globs": must be units, pages, or pixels}} test textDisp-14.16 {TkTextXviewCmd procedure} { list [catch {.t xview flounder} msg] $msg -} {1 {unknown option "flounder": must be moveto or scroll}} +} {1 {bad option "flounder": must be moveto or scroll}} .t configure -wrap char .t delete 1.0 end @@ -1615,6 +1740,36 @@ test textDisp-15.7 {ScrollByLines procedure, scrolling forwards} { .t index @0,0 } {50.40} +test textDisp-15.8 {Scrolling near end of window} { + set textheight 12 + set textwidth 30 + + toplevel .tf + frame .tf.f -relief sunken -borderwidth 2 + pack .tf.f -padx 10 -pady 10 + + text .tf.f.t -font {Courier 9} -height $textheight \ + -width $textwidth -yscrollcommand ".tf.f.sb set" + scrollbar .tf.f.sb -command ".tf.f.t yview" + pack .tf.f.t -side left -expand 1 -fill both + pack .tf.f.sb -side right -fill y + + .tf.f.t tag configure Header -font {Helvetica 14 bold italic} \ + -wrap word -spacing1 12 -spacing3 4 + + .tf.f.t insert end "Foo" Header + for {set i 1} {$i < $textheight} {incr i} { + .tf.f.t insert end "\nLine $i" + } + update ; after 1000 ; update + # Should scroll and should not crash! + .tf.f.t yview scroll 1 unit + # Check that it has scrolled + set res [.tf.f.t index @0,[expr [winfo height .tf.f.t] - 15]] + destroy .tf + set res +} {12.0} + .t configure -wrap char .t delete 1.0 end .t insert insert "Line 1" @@ -1624,16 +1779,16 @@ for {set i 2} {$i <= 200} {incr i} { .t tag add big 100.0 105.0 .t insert 151.end { has a lot of extra text, so that it wraps around on the screen several times over.} .t insert 153.end { also has enoug extra text to wrap.} -update +update ; .t count -update -ypixels 1.0 end test textDisp-16.1 {TkTextYviewCmd procedure} { .t yview 21.0 set x [.t yview] .t yview 1.0 - set x -} {0.1 0.15} + list [expr {int([lindex $x 0]*100)}] [expr {int ([lindex $x 1] * 100)}] +} {9 14} test textDisp-16.2 {TkTextYviewCmd procedure} { list [catch {.t yview 2 3} msg] $msg -} {1 {unknown option "2": must be moveto or scroll}} +} {1 {bad option "2": must be moveto or scroll}} test textDisp-16.3 {TkTextYviewCmd procedure} { list [catch {.t yview -pickplace} msg] $msg } {1 {wrong # args: should be ".t yview -pickplace lineNum|index"}} @@ -1642,7 +1797,7 @@ test textDisp-16.4 {TkTextYviewCmd procedure} { } {1 {wrong # args: should be ".t yview -pickplace lineNum|index"}} test textDisp-16.5 {TkTextYviewCmd procedure} { list [catch {.t yview -bogus 2} msg] $msg -} {1 {unknown option "-bogus": must be moveto or scroll}} +} {1 {bad option "-bogus": must be moveto or scroll}} test textDisp-16.6 {TkTextYviewCmd procedure, integer position} { .t yview 100.0 update @@ -1666,7 +1821,7 @@ test textDisp-16.10 {TkTextYviewCmd procedure, "moveto" option} { test textDisp-16.11 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto 0.5 .t index @0,0 -} {101.0} +} {103.0} test textDisp-16.12 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto -1 .t index @0,0 @@ -1678,20 +1833,22 @@ test textDisp-16.13 {TkTextYviewCmd procedure, "moveto" option} { test textDisp-16.14 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto .75 .t index @0,0 -} {151.0} +} {151.60} test textDisp-16.15 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto .752 .t index @0,0 -} {151.20} -test textDisp-16.16 {TkTextYviewCmd procedure, "moveto" option} { - .t yview moveto .754 +} {151.60} +test textDisp-16.16 {TkTextYviewCmd procedure, "moveto" option} {textfonts} { + set count [expr {5 * $bigHeight + 150 * $fixedHeight}] + set extra [expr {0.04 * double($fixedDiff * 150) / double($count)}] + .t yview moveto [expr {.753 - $extra}] .t index @0,0 } {151.60} test textDisp-16.17 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto .755 .t index @0,0 -} {152.0} -test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {fonts} { +} {151.80} +test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {textfonts} { catch {destroy .top1} toplevel .top1 wm geometry .top1 +0+0 @@ -1704,15 +1861,18 @@ test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {fonts} { set result [.top1.t yview] destroy .top1 set result -} {0.333333 0.833333} +} [list [expr {1.0/3}] [expr {5.0/6}]] test textDisp-16.19 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll a} msg] $msg -} {1 {wrong # args: should be ".t yview scroll number units|pages"}} +} {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}} test textDisp-16.20 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll a b c} msg] $msg -} {1 {wrong # args: should be ".t yview scroll number units|pages"}} +} {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}} test textDisp-16.21 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll badInt bogus} msg] $msg +} {1 {bad argument "bogus": must be units, pages, or pixels}} +test textDisp-16.21.2 {TkTextYviewCmd procedure, "scroll" option} { + list [catch {.t yview scroll badInt units} msg] $msg } {1 {expected integer but got "badInt"}} test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 @@ -1720,16 +1880,19 @@ test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview scroll -1 pages .t index @0,0 } {42.0} +test textDisp-16.22.1 {TkTextYviewCmd procedure, "scroll" option, back pages} { + list [catch {.t yview scroll -3 p} res] $res +} {1 {ambiguous argument "p": must be units, pages, or pixels}} test textDisp-16.23 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 update - .t yview scroll -3 p + .t yview scroll -3 pa .t index @0,0 } {26.0} test textDisp-16.24 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 5.0 update - .t yview scroll -3 p + .t yview scroll -3 pa .t index @0,0 } {1.0} test textDisp-16.25 {TkTextYviewCmd procedure, "scroll" option, back pages} { @@ -1755,12 +1918,16 @@ test textDisp-16.27 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t yview scroll 2 pages .t index @0,0 } {66.0} -test textDisp-16.28 {TkTextYviewCmd procedure, "scroll" option, forward pages} {fonts} { +test textDisp-16.28 {TkTextYviewCmd procedure, "scroll" option, forward pages} {textfonts} { .t yview 98.0 update .t yview scroll 1 page - .t index @0,0 -} {103.0} + set res [expr int([.t index @0,0])] + if {$fixedDiff > 1} { + incr res -1 + } + set res +} {102} test textDisp-16.29 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t configure -height 1 update @@ -1786,10 +1953,71 @@ test textDisp-16.31 {TkTextYviewCmd procedure, "scroll units" option} { } {151.40} test textDisp-16.32 {TkTextYviewCmd procedure} { list [catch {.t yview scroll 12 bogoids} msg] $msg -} {1 {bad argument "bogoids": must be units or pages}} +} {1 {bad argument "bogoids": must be units, pages, or pixels}} test textDisp-16.33 {TkTextYviewCmd procedure} { list [catch {.t yview bad_arg 1 2} msg] $msg -} {1 {unknown option "bad_arg": must be moveto or scroll}} +} {1 {bad option "bad_arg": must be moveto or scroll}} +test textDisp-16.34 {TkTextYviewCmd procedure} { + set res {} + .t yview 1.0 + lappend res [format %.12g [expr {[lindex [.t yview] 0] + * [.t count -ypixels 1.0 end]}]] + .t yview scroll 1 pixels + lappend res [format %.12g [expr {[lindex [.t yview] 0] + * [.t count -ypixels 1.0 end]}]] + .t yview scroll 1 pixels + lappend res [format %.12g [expr {[lindex [.t yview] 0] + * [.t count -ypixels 1.0 end]}]] + .t yview scroll 1 pixels + lappend res [format %.12g [expr {[lindex [.t yview] 0] + * [.t count -ypixels 1.0 end]}]] + .t yview scroll 1 pixels + lappend res [format %.12g [expr {[lindex [.t yview] 0] + * [.t count -ypixels 1.0 end]}]] + .t yview scroll 1 pixels + lappend res [format %.12g [expr {[lindex [.t yview] 0] + * [.t count -ypixels 1.0 end]}]] +} {0 1 2 3 4 5} +test textDisp-16.35 {TkTextYviewCmd procedure} { + set res {} + .t yview 1.0 + lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}] + .t yview scroll 13 pixels + lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}] + .t yview scroll -4 pixels + lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}] + .t yview scroll -9 pixels + lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}] +} {0 13 9 0} +test textDisp-16.36 {TkTextYviewCmd procedure} { + set res {} + .t yview 1.0 + .t yview scroll 5 pixels + .t yview scroll -1 pages + lappend res [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}] + .t yview scroll 5 pixels + .t yview scroll -1 units + lappend res [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}] +} {0.0 0.0} +test textDisp-16.37 {TkTextYviewCmd procedure} { + list [catch {.t yview scroll 1.3 pixels} msg] $msg +} {0 {}} +test textDisp-16.38 {TkTextYviewCmd procedure} { + list [catch {.t yview scroll 1.3blah pixels} msg] $msg +} {1 {bad screen distance "1.3blah"}} +test textDisp-16.39 {TkTextYviewCmd procedure} { + list [catch {.t yview scroll 1.3i pixels} msg] $msg +} {0 {}} +test textDisp-16.40 {text count -xpixels} { + set res {} + lappend res [.t count -xpixels 1.0 1.5] \ + [.t count -xpixels 1.5 1.0] \ + [.t count -xpixels 1.0 13.0] \ + [.t count -xpixels 1.0 "1.0 displaylineend"] \ + [.t count -xpixels 1.0 "1.0 lineend"] \ + [.t count -xpixels 1.0 "1.0 displaylineend"] \ + [.t count -xpixels 1.0 end] +} {35 -35 0 42 42 42 0} .t delete 1.0 end foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} { @@ -1812,14 +2040,14 @@ test textDisp-17.4 {TkTextScanCmd procedure} { test textDisp-17.5 {TkTextScanCmd procedure} { list [catch {.t scan stupid 123 456} msg] $msg } {1 {bad scan option "stupid": must be mark or dragto}} -test textDisp-17.6 {TkTextScanCmd procedure} {fonts} { +test textDisp-17.6 {TkTextScanCmd procedure} {textfonts} { .t yview 1.0 .t xview moveto 0 .t scan mark 40 60 .t scan dragto 35 55 .t index @0,0 } {4.7} -test textDisp-17.7 {TkTextScanCmd procedure} {fonts} { +test textDisp-17.7 {TkTextScanCmd procedure} {textfonts} { .t yview 10.0 .t xview moveto 0 .t xview scroll 20 units @@ -1827,10 +2055,10 @@ test textDisp-17.7 {TkTextScanCmd procedure} {fonts} { .t scan dragto -5 65 .t index @0,0 set x [.t index @0,0] - .t scan dragto 0 70 + .t scan dragto 0 [expr {70 + $fixedDiff}] list $x [.t index @0,0] -} {7.13 3.6} -test textDisp-17.8 {TkTextScanCmd procedure} {fonts} { +} {6.12 2.5} +test textDisp-17.8 {TkTextScanCmd procedure} {textfonts} { .t yview 1.0 .t xview moveto 0 .t scan mark 0 60 @@ -1838,25 +2066,24 @@ test textDisp-17.8 {TkTextScanCmd procedure} {fonts} { .t scan dragto 25 95 .t index @0,0 } {4.7} -test textDisp-17.9 {TkTextScanCmd procedure} {fonts} { +test textDisp-17.9 {TkTextScanCmd procedure} {textfonts} { .t yview end .t xview moveto 0 .t xview scroll 100 units .t scan mark 90 60 .t scan dragto 10 0 - .t scan dragto 15 5 + .t scan dragto 14 5 .t index @0,0 } {18.44} .t configure -wrap word -test textDisp-17.10 {TkTextScanCmd procedure, word wrapping} {fonts} { +test textDisp-17.10 {TkTextScanCmd procedure, word wrapping} {textfonts} { .t yview 10.0 .t scan mark -10 60 .t scan dragto -5 65 set x [.t index @0,0] - .t scan dragto 0 70 + .t scan dragto 0 [expr {70 + $fixedDiff}] list $x [.t index @0,0] -} {9.31 8.47} - +} {9.15 8.31} .t configure -xscrollcommand scroll -yscrollcommand {} test textDisp-18.1 {GetXView procedure} { .t configure -wrap none @@ -1866,7 +2093,7 @@ test textDisp-18.1 {GetXView procedure} { .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx update set scrollInfo -} {0 0.363636} +} [list 0.0 [expr {4.0/11}]] test textDisp-18.2 {GetXView procedure} { .t configure -wrap char .t delete 1.0 end @@ -1875,13 +2102,13 @@ test textDisp-18.2 {GetXView procedure} { .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx update set scrollInfo -} {0 1} +} {0.0 1.0} test textDisp-18.3 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end update set scrollInfo -} {0 1} +} {0.0 1.0} test textDisp-18.4 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end @@ -1890,7 +2117,7 @@ test textDisp-18.4 {GetXView procedure} { .t insert end xxxxxxxxxxxxxxxxx update set scrollInfo -} {0 1} +} {0.0 1.0} test textDisp-18.5 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end @@ -1900,7 +2127,7 @@ test textDisp-18.5 {GetXView procedure} { .t xview scroll 31 units update set scrollInfo -} {0.563636 0.927273} +} [list [expr {31.0/55}] [expr {51.0/55}]] test textDisp-18.6 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end @@ -1921,7 +2148,7 @@ test textDisp-18.6 {GetXView procedure} { .t configure -wrap none update lappend x $scrollInfo -} {{0.553571 0.910714} {0 1} {0 1} {0 0.357143}} +} [list [list [expr {31.0/56}] [expr {51.0/56}]] {0.0 1.0} {0.0 1.0} [list 0.0 [expr {5.0/14}]]] test textDisp-18.7 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end @@ -1953,7 +2180,7 @@ test textDisp-18.8 {GetXView procedure} { "error "scrolling error"" (procedure "scrollError" line 2) invoked from within -"scrollError 0 1" +"scrollError 0.0 1.0" (horizontal scrolling command executed by text)}} catch {rename bgerror {}} catch {rename bogus {}} @@ -1965,7 +2192,7 @@ test textDisp-19.1 {GetYView procedure} { .t delete 1.0 end update set scrollInfo -} {0 1} +} {0.0 1.0} test textDisp-19.2 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -1978,7 +2205,7 @@ test textDisp-19.2 {GetYView procedure} { test textDisp-19.3 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end - update + update; after 10 ; update set scrollInfo "unchanged" .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around\nLine 3" update @@ -1995,7 +2222,7 @@ test textDisp-19.4 {GetYView procedure} { } update set scrollInfo -} {0 0.769231} +} [list 0.0 [expr {70.0/91}]] test textDisp-19.5 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -2004,9 +2231,9 @@ test textDisp-19.5 {GetYView procedure} { .t insert end "\nLine $i" } .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" - update + update ; after 100 set x $scrollInfo -} {0 0.538462} +} {0.0 0.625} test textDisp-19.6 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -2018,7 +2245,7 @@ test textDisp-19.6 {GetYView procedure} { .t yview 4.0 update set x $scrollInfo -} {0.230769 1} +} {0.375 1.0} test textDisp-19.7 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -2028,9 +2255,9 @@ test textDisp-19.7 {GetYView procedure} { } .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" .t yview 2.26 - update + update; after 1; update set x $scrollInfo -} {0.097166 0.692308} +} {0.125 0.75} test textDisp-19.8 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -2041,8 +2268,9 @@ test textDisp-19.8 {GetYView procedure} { .t insert 10.end " is really quite long; in fact it's so long that it wraps three times" .t yview 2.0 update + .t count -update -ypixels 1.0 end set x $scrollInfo -} {0.0769231 0.732268} +} {0.0625 0.6875} test textDisp-19.9 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -2053,7 +2281,7 @@ test textDisp-19.9 {GetYView procedure} { .t yview 3.0 update set scrollInfo -} {0.133333 0.8} +} [list [expr {4.0/30}] 0.8] test textDisp-19.10 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -2064,7 +2292,29 @@ test textDisp-19.10 {GetYView procedure} { .t yview 11.0 update set scrollInfo -} {0.333333 1} +} [list [expr {1.0/3}] 1.0] +test textDisp-19.10.1 {Widget manipulation causes height miscount} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "Line 1" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + .t yview 11.0 + update + .t configure -wrap word + .t delete 1.0 end + .t insert 1.0 "Line 1" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + .t insert end "\nThis last line wraps around four " + .t insert end "times with a bit left on the last line." + .t yview insert + update + .t count -update -ypixels 1.0 end + set scrollInfo +} {0.5 1.0} test textDisp-19.11 {GetYView procedure} { .t configure -wrap word .t delete 1.0 end @@ -2076,34 +2326,163 @@ test textDisp-19.11 {GetYView procedure} { .t insert end "times with a bit left on the last line." .t yview insert update + .t count -update -ypixels 1.0 end set scrollInfo -} {0.625 1} +} {0.5 1.0} +test textDisp-19.11.2 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines 1.0 end +} {20} +test textDisp-19.11.3 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines end 1.0 +} {-20} +test textDisp-19.11.4 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines 1.1 1.3 +} {0} +test textDisp-19.11.5 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines 16.0 16.1 +} {0} +test textDisp-19.11.5.1 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines 16.0 16.5 +} {0} +test textDisp-19.11.6 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines 16.0 16.20 +} {1} +test textDisp-19.11.7 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines 16.0 16.40 +} {2} +test textDisp-19.11.8 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines "16.0 displaylineend +1c" "16.0 lineend" +} {3} +test textDisp-19.11.9 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines 16.0 "16.0 lineend" +} {4} +test textDisp-19.11.10 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines 16.0 "16.0 +4displaylines" +} {4} +test textDisp-19.11.11 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines 16.0 "16.0 +2displaylines" +} {2} +test textDisp-19.11.12 {TextWidgetCmd procedure, "count -displaylines"} { + .t count -displaylines "16.0 +1displayline" "16.0 +2displaylines -1c" +} {0} +.t tag configure elide -elide 1 +test textDisp-19.11.13 {TextWidgetCmd procedure, "count -displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines +6c" + .t count -displaylines 16.0 "16.0 +4displaylines" +} {4} +test textDisp-19.11.14 {TextWidgetCmd procedure, "count -displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines displaylineend" + .t count -displaylines 16.0 "16.0 +4displaylines" +} {4} +test textDisp-19.11.15 {TextWidgetCmd procedure, "count -displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "16.0 +1displaylines" "16.0 +2displaylines" + .t count -displaylines 16.0 "16.0 +4displaylines -1c" +} {3} +test textDisp-19.11.15a {TextWidgetCmd procedure, "count -displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "16.0 +1displaylines" "16.0 +2displaylines" + .t count -displaylines 16.0 "16.0 +4displaylines" +} {4} +test textDisp-19.11.16 {TextWidgetCmd procedure, "count -displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "12.0" "14.0" + .t count -displaylines 12.0 16.0 +} {2} +test textDisp-19.11.17 {TextWidgetCmd procedure, "index +displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "12.0" "14.0" + list [.t index "11.5 +2d lines"] \ + [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \ + [.t index "13.0 +2d lines"] [.t index "13.1 +3d lines"] \ + [.t index "13.0 +4d lines"] +} {15.5 16.0 15.0 16.0 16.15 16.33} +test textDisp-19.11.18 {TextWidgetCmd procedure, "index +displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "12.0" "14.0" + list [.t index "15.5 -2d lines"] \ + [.t index "16.0 -2d lines"] [.t index "15.0 -2d lines"] \ + [.t index "16.0 -3d lines"] [.t index "16.17 -4d lines"] \ + [.t index "16.36 -5d lines"] +} {11.5 14.0 11.0 11.0 11.2 11.3} +test textDisp-19.11.19 {TextWidgetCmd procedure, "count -displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "12.0" "16.0 +1displaylines" + .t count -displaylines 12.0 17.0 +} {4} +test textDisp-19.11.20 {TextWidgetCmd procedure, "index +displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "12.0" "16.0 +1displaylines" + list [.t index "11.5 +2d lines"] \ + [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \ + [.t index "13.0 +2d lines"] [.t index "13.0 +3d lines"] \ + [.t index "13.0 +4d lines"] +} {16.38 16.50 16.33 16.50 16.67 17.0} +test textDisp-19.11.21 {TextWidgetCmd procedure, "index +displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "12.0" "16.0 +1displaylines" + list [.t index "16.38 -2d lines"] \ + [.t index "16.50 -3d lines"] [.t index "16.33 -2d lines"] \ + [.t index "16.53 -4d lines"] [.t index "16.69 -4d lines"] \ + [.t index "17.1 -5d lines"] +} {11.5 11.0 11.0 10.3 11.2 11.0} +test textDisp-19.11.22 {TextWidgetCmd procedure, "index +displaylines"} { + .t tag remove elide 1.0 end + list [.t index "end +5d lines"] \ + [.t index "end -3d lines"] [.t index "1.0 -2d lines"] \ + [.t index "1.0 +4d lines"] [.t index "1.0 +50d lines"] \ + [.t index "end -50d lines"] +} {17.0 16.33 1.0 5.0 17.0 1.0} +test textDisp-19.11.23 {TextWidgetCmd procedure, "index +displaylines"} { + .t tag remove elide 1.0 end + .t tag add elide "12.3" "16.0 +1displaylines" + list [.t index "11.5 +1d lines"] [.t index "11.5 +2d lines"] \ + [.t index "12.0 +1d lines"] \ + [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \ + [.t index "13.0 +2d lines"] [.t index "13.0 +3d lines"] \ + [.t index "13.0 +4d lines"] +} {16.17 16.33 16.28 16.46 16.28 16.49 16.65 17.0} +.t tag remove elide 1.0 end +test textDisp-19.11.24 {TextWidgetCmd procedure, "index +/-displaylines"} { + list [.t index "11.5 + -1 display lines"] \ + [.t index "11.5 + +1 disp lines"] \ + [.t index "11.5 - -1 disp lines"] \ + [.t index "11.5 - +1 disp lines"] \ + [.t index "11.5 -1 disp lines"] \ + [.t index "11.5 +1 disp lines"] \ + [.t index "11.5 +0 disp lines"] +} {10.5 12.5 12.5 10.5 10.5 12.5 11.5} +.t tag remove elide 1.0 end test textDisp-19.12 {GetYView procedure, partially visible last line} { catch {destroy .top} toplevel .top wm geometry .top +0+0 - text .top.t -width 40 -height 5 + text .top.t -width 40 -height 5 -font $fixedFont pack .top.t -expand yes -fill both .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5" - update + # Need to wait for asychronous calculations to complete. + update ; after 10 scan [wm geom .top] %dx%d twidth theight wm geom .top ${twidth}x[expr $theight - 3] update .top.t yview -} {0 0.8} -test textDisp-19.13 {GetYView procedure, partially visible last line} {fonts} { +} [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]] +test textDisp-19.13 {GetYView procedure, partially visible last line} {textfonts} { catch {destroy .top} toplevel .top wm geometry .top +0+0 - text .top.t -width 40 -height 5 + text .top.t -width 40 -height 5 -font $fixedFont pack .top.t -expand yes -fill both .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4 has enough text to wrap around at least once" - update + # Need to wait for asychronous calculations to complete. + update ; after 10 scan [wm geom .top] %dx%d twidth theight wm geom .top ${twidth}x[expr $theight - 3] update .top.t yview -} {0 0.942308} +} [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]] catch {destroy .top} test textDisp-19.14 {GetYView procedure} { .t configure -wrap word @@ -2114,7 +2493,9 @@ test textDisp-19.14 {GetYView procedure} { } .t insert end "\nThis last line wraps around four " .t insert end "times with a bit left on the last line." - update + # Need to update so everything is calculated. + update ; .t count -update -ypixels 1.0 end + update ; after 10 ; update set scrollInfo "unchanged" .t mark set insert 3.0 .t tag configure x -background red @@ -2148,9 +2529,29 @@ test textDisp-19.15 {GetYView procedure} { "error "scrolling error"" (procedure "scrollError" line 2) invoked from within -"scrollError 0 1" +"scrollError 0.0 1.0" (vertical scrolling command executed by text)} NONE} +test textDisp-19.16 {count -ypixels} { + .t configure -wrap word + .t delete 1.0 end + .t insert 1.0 "Line 1" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + .t insert end "\nThis last line wraps around four " + .t insert end "times with a bit left on the last line." + # Need to update so everything is calculated. + update ; .t count -update -ypixels 1.0 end ; update + set res {} + lappend res \ + [.t count -ypixels 1.0 end] \ + [.t count -update -ypixels 1.0 end] \ + [.t count -ypixels 15.0 16.0] \ + [.t count -ypixels 15.0 "16.0 displaylineend +1c"] \ + [.t count -ypixels 16.0 "16.0 displaylineend +1c"] \ + [.t count -ypixels "16.0 +1 displaylines" "16.0 +4 displaylines +3c"] +} [list [expr {260 + 20 * $fixedDiff}] [expr {260 + 20 * $fixedDiff}] $fixedHeight [expr {2*$fixedHeight}] $fixedHeight [expr {3*$fixedHeight}]] .t delete 1.0 end .t insert end "Line 1" for {set i 2} {$i <= 200} {incr i} { @@ -2159,46 +2560,46 @@ for {set i 2} {$i <= 200} {incr i} { .t configure -wrap word .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" -test textDisp-20.1 {FindDLine} {fonts} { +test textDisp-20.1 {FindDLine} {textfonts} { .t yview 48.0 list [.t dlineinfo 46.0] [.t dlineinfo 47.0] [.t dlineinfo 49.0] \ [.t dlineinfo 58.0] -} {{} {} {3 16 49 13 10} {}} -test textDisp-20.2 {FindDLine} {fonts} { +} [list {} {} [list 3 [expr {$fixedDiff + 16}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] +test textDisp-20.2 {FindDLine} {textfonts} { .t yview 100.0 .t yview -pickplace 53.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.14] [.t dlineinfo 50.15] -} {{} {} {3 3 140 13 10}} -test textDisp-20.3 {FindDLine} {fonts} { +} [list [list 3 [expr {-1 - $fixedDiff/2}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {-1 - $fixedDiff/2}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {12 + $fixedDiff/2}] 140 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] +test textDisp-20.3 {FindDLine} {textfonts} { .t yview 100.0 .t yview 49.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 57.0] -} {{3 16 105 13 10} {3 29 140 13 10} {}} -test textDisp-20.4 {FindDLine} {fonts} { +} [list [list 3 [expr {$fixedDiff + 16}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {2*$fixedDiff + 29}] 140 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] +test textDisp-20.4 {FindDLine} {textfonts} { .t yview 100.0 .t yview 42.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 50.40] -} {{3 107 105 13 10} {3 120 140 13 10} {}} +} [list [list 3 [expr {8*$fixedDiff + 107}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {9*$fixedDiff + 120}] 140 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] .t config -wrap none -test textDisp-20.5 {FindDLine} {fonts} { +test textDisp-20.5 {FindDLine} {textfonts} { .t yview 100.0 .t yview 48.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 50.40] -} {{3 29 371 13 10} {3 29 371 13 10} {3 29 371 13 10}} +} [list [list 3 [expr {3+2*$fixedHeight}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {3+2*$fixedHeight}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {3+2*$fixedHeight}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] .t config -wrap word -test textDisp-21.1 {TkTextPixelIndex} {fonts} { +test textDisp-21.1 {TkTextPixelIndex} {textfonts} { .t yview 48.0 list [.t index @-10,-10] [.t index @6,6] [.t index @22,6] \ - [.t index @102,6] [.t index @38,55] [.t index @44,67] + [.t index @102,6] [.t index @38,[expr {$fixedHeight * 4 + 3}]] [.t index @44,67] } {48.0 48.0 48.2 48.7 50.40 50.40} .t insert end \n -test textDisp-21.2 {TkTextPixelIndex} {fonts} { +test textDisp-21.2 {TkTextPixelIndex} {textfonts} { .t yview 195.0 - list [.t index @11,70] [.t index @11,84] [.t index @11,102] \ + list [.t index @11,[expr {$fixedHeight * 5 + 5}]] [.t index @11,[expr {$fixedHeight * 6 + 5}]] [.t index @11,[expr {$fixedHeight * 7 + 5}]] \ [.t index @11,1002] } {197.1 198.1 199.1 201.0} -test textDisp-21.3 {TkTextPixelIndex, horizontal scrolling} {fonts} { +test textDisp-21.3 {TkTextPixelIndex, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "12345\n" @@ -2206,6 +2607,31 @@ test textDisp-21.3 {TkTextPixelIndex, horizontal scrolling} {fonts} { .t xview scroll 2 units list [.t index @-5,7] [.t index @5,7] [.t index @33,20] } {1.2 1.2 2.6} +test textDisp-21.4 {count -displaylines regression} { + set message { + QOTW: "C/C++, which is used by 16% of users, is the most popular programming language, but Tcl, used by 0%, seems to be the language of choice for the highest scoring users." +(new line) +Use the Up (cursor) key to scroll up one line at a time. At the second press, the cursor either gets locked or jumps several lines. + +Connect with Tkcon. The command +.u count -displaylines \ +3.10 2.173 +should give answer -1; it gives me 5. + +Using 8.5a4 (ActiveState beta 4) under Linux. No problem with ActiveState beta 3. +} + +toplevel .tt +pack [text .tt.u] -side right +.tt.u configure -width 30 -height 27 -wrap word -bg #FFFFFF +.tt.u insert end $message +.tt.u mark set insert 3.10 +tkwait visibility .tt.u +set res [.tt.u count -displaylines 3.10 2.173] +destroy .tt +unset message +set res +} {-1} .t delete 1.0 end .t insert end "Line 1" @@ -2217,57 +2643,57 @@ for {set i 2} {$i <= 200} {incr i} { .t insert 50.0 "This is a long line, one that will wrap around twice.\n" update .t tag add x 50.1 -test textDisp-22.1 {TkTextCharBbox} {fonts} { +test textDisp-22.1 {TkTextCharBbox} {textfonts} { .t config -wrap word .t yview 48.0 list [.t bbox 47.2] [.t bbox 48.0] [.t bbox 50.5] [.t bbox 50.40] \ [.t bbox 58.0] -} {{} {3 3 7 13} {38 29 7 13} {38 55 7 13} {}} -test textDisp-22.2 {TkTextCharBbox} {fonts} { +} [list {} [list 3 3 7 $fixedHeight] [list 38 [expr {3+2*$fixedHeight}] 7 $fixedHeight] [list 38 [expr {3+4*$fixedHeight}] 7 $fixedHeight] {}] +test textDisp-22.2 {TkTextCharBbox} {textfonts} { .t config -wrap none .t yview 48.0 list [.t bbox 50.5] [.t bbox 50.40] [.t bbox 57.0] -} {{38 29 7 13} {} {3 120 7 13}} -test textDisp-22.3 {TkTextCharBbox, cut-off lines} {fonts} { +} [list [list 38 [expr {3+2*$fixedHeight}] 7 $fixedHeight] {} [list 3 [expr {3+9*$fixedHeight}] 7 $fixedHeight]] +test textDisp-22.3 {TkTextCharBbox, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 wm geom . ${width}x[expr $height-1] update list [.t bbox 19.1] [.t bbox 20.1] -} {{10 120 7 13} {10 133 7 3}} -test textDisp-22.4 {TkTextCharBbox, cut-off lines} {fonts} { +} [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] [list 10 [expr {3+10*$fixedHeight}] 7 3]] +test textDisp-22.4 {TkTextCharBbox, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 wm geom . ${width}x[expr $height+1] update list [.t bbox 19.1] [.t bbox 20.1] -} {{10 120 7 13} {10 133 7 5}} -test textDisp-22.5 {TkTextCharBbox, cut-off char} {fonts} { +} [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] [list 10 [expr {3+10*$fixedHeight}] 7 5]] +test textDisp-22.5 {TkTextCharBbox, cut-off char} {textfonts} { .t config -wrap none .t yview 10.0 wm geom . [expr $width-95]x$height update .t bbox 15.6 -} {45 68 7 13} -test textDisp-22.6 {TkTextCharBbox, line visible but not char} {fonts} { +} [list 45 [expr {3+5*$fixedHeight}] 7 $fixedHeight] +test textDisp-22.6 {TkTextCharBbox, line visible but not char} {textfonts} { .t config -wrap char .t yview 10.0 .t tag add big 20.2 20.5 wm geom . ${width}x[expr $height+3] update list [.t bbox 19.1] [.t bbox 20.1] [.t bbox 20.2] -} {{10 120 7 13} {} {17 133 14 7}} +} [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] {} [list 17 [expr {3+10*$fixedHeight}] 14 7]] wm geom . {} update -test textDisp-22.7 {TkTextCharBbox, different character sizes} {fonts} { +test textDisp-22.7 {TkTextCharBbox, different character sizes} {textfonts} { .t config -wrap char .t yview 10.0 .t tag add big 12.2 12.5 update list [.t bbox 12.1] [.t bbox 12.2] -} {{10 41 7 13} {17 29 14 27}} +} [list [list 10 [expr {3 + 2*$fixedHeight + $ascentDiff}] 7 $fixedHeight] [list 17 [expr {3+ 2*$fixedHeight}] 14 27]] .t tag remove big 1.0 end -test textDisp-22.8 {TkTextCharBbox, horizontal scrolling} {fonts} { +test textDisp-22.8 {TkTextCharBbox, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "12345\n" @@ -2275,8 +2701,8 @@ test textDisp-22.8 {TkTextCharBbox, horizontal scrolling} {fonts} { .t xview scroll 4 units list [.t bbox 1.3] [.t bbox 1.4] [.t bbox 2.3] [.t bbox 2.4] \ [.t bbox 2.23] [.t bbox 2.24] -} {{} {3 3 7 13} {} {3 16 7 13} {136 16 7 13} {}} -test textDisp-22.9 {TkTextCharBbox, handling of spacing} {fonts} { +} [list {} [list 3 3 7 $fixedHeight] {} [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 136 [expr {$fixedDiff + 16}] 7 $fixedHeight] {}] +test textDisp-22.9 {TkTextCharBbox, handling of spacing} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz" @@ -2293,7 +2719,7 @@ test textDisp-22.9 {TkTextCharBbox, handling of spacing} {fonts} { update list [.t bbox .t.f1] [.t bbox .t.f2] [.t bbox .t.f3] [.t bbox .t.f4] \ [.t bbox 1.1] [.t bbox 2.9] -} {{24 11 10 4} {55 15 10 4} {10 43 10 4} {76 40 10 4} {10 11 7 13} {69 34 7 13}} +} [list [list 24 11 10 4] [list 55 [expr {$fixedDiff/2 + 15}] 10 4] [list 10 [expr {2*$fixedDiff + 43}] 10 4] [list 76 [expr {2*$fixedDiff + 40}] 10 4] [list 10 11 7 $fixedHeight] [list 69 [expr {$fixedDiff + 34}] 7 $fixedHeight]] .t tag delete spacing .t delete 1.0 end @@ -2305,42 +2731,42 @@ for {set i 2} {$i <= 200} {incr i} { .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" update -test textDisp-23.1 {TkTextDLineInfo} {fonts} { +test textDisp-23.1 {TkTextDLineInfo} {textfonts} { .t config -wrap word .t yview 48.0 list [.t dlineinfo 47.3] [.t dlineinfo 48.0] [.t dlineinfo 50.40] \ [.t dlineinfo 56.0] -} {{} {3 3 49 13 10} {3 55 126 13 10} {}} -test textDisp-23.2 {TkTextDLineInfo} {fonts} { +} [list {} [list 3 3 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {4*$fixedDiff + 55}] 126 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] +test textDisp-23.2 {TkTextDLineInfo} {textfonts} { .t config -bd 4 -wrap word update .t yview 48.0 .t dlineinfo 50.40 -} {7 59 126 13 10} +} [list 7 [expr {4*$fixedDiff + 59}] 126 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] .t config -bd 0 -test textDisp-23.3 {TkTextDLineInfo} {fonts} { +test textDisp-23.3 {TkTextDLineInfo} {textfonts} { .t config -wrap none update .t yview 48.0 list [.t dlineinfo 50.40] [.t dlineinfo 57.3] -} {{3 29 371 13 10} {3 120 49 13 10}} -test textDisp-23.4 {TkTextDLineInfo, cut-off lines} {fonts} { +} [list [list 3 [expr {2*$fixedDiff + 29}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] +test textDisp-23.4 {TkTextDLineInfo, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 wm geom . ${width}x[expr $height-1] update list [.t dlineinfo 19.0] [.t dlineinfo 20.0] -} {{3 120 49 13 10} {3 133 49 3 10}} -test textDisp-23.5 {TkTextDLineInfo, cut-off lines} {fonts} { +} [list [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {10*$fixedDiff + 133}] 49 3 [expr {$fixedDiff + 10}]]] +test textDisp-23.5 {TkTextDLineInfo, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 wm geom . ${width}x[expr $height+1] update list [.t dlineinfo 19.0] [.t dlineinfo 20.0] -} {{3 120 49 13 10} {3 133 49 5 10}} +} [list [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {10*$fixedDiff + 133}] 49 5 [expr {$fixedDiff + 10}]]] wm geom . {} update -test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} {fonts} { +test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} {textfonts} { .t config -wrap none .t delete 1.0 end .t insert end "First line\n" @@ -2349,9 +2775,9 @@ test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} {fonts} { .t xview scroll 6 units update list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0] -} {{-39 3 70 13 10} {-39 16 364 13 10} {-39 29 35 13 10}} +} [list [list -39 3 70 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list -39 [expr {$fixedDiff + 16}] 364 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list -39 [expr {2*$fixedDiff + 29}] 35 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] .t xview moveto 0 -test textDisp-23.7 {TkTextDLineInfo, centering} {fonts} { +test textDisp-23.7 {TkTextDLineInfo, centering} {textfonts} { .t config -wrap word .t delete 1.0 end .t insert end "First line\n" @@ -2362,88 +2788,88 @@ test textDisp-23.7 {TkTextDLineInfo, centering} {fonts} { .t tag add x 1.0 .t tag add y 3.0 list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0] -} {{38 3 70 13 10} {3 16 119 13 10} {108 55 35 13 10}} +} [list [list 38 3 70 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {$fixedDiff + 16}] 119 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 108 [expr {4*$fixedDiff + 55}] 35 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] .t tag delete x y -test textDisp-24.1 {TkTextCharLayoutProc} {fonts} { +test textDisp-24.1 {TkTextCharLayoutProc} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 7 13} {3 16 7 13}} -test textDisp-24.2 {TkTextCharLayoutProc} {fonts} { +} [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.2 {TkTextCharLayoutProc} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . [expr $width+1]x$height update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 12 13} {3 16 7 13}} -test textDisp-24.3 {TkTextCharLayoutProc} {fonts} { +} [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.3 {TkTextCharLayoutProc} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . [expr $width-1]x$height update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 10 13} {3 16 7 13}} -test textDisp-24.4 {TkTextCharLayoutProc, newline not visible} {fonts} { +} [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.4 {TkTextCharLayoutProc, newline not visible} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 01234567890123456789\n012345678901234567890 wm geom . {} update list [.t bbox 1.19] [.t bbox 1.20] [.t bbox 2.20] -} {{136 3 7 13} {143 3 0 13} {3 29 7 13}} -test textDisp-24.5 {TkTextCharLayoutProc, char doesn't fit, newline not visible} {fonts} { +} [list [list 136 3 7 $fixedHeight] [list 143 3 0 $fixedHeight] [list 3 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]] +test textDisp-24.5 {TkTextCharLayoutProc, char doesn't fit, newline not visible} {unix textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 0\n1\n wm geom . 110x$height update list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 2.0] -} {{3 3 4 13} {7 3 0 13} {3 16 4 13}} -test textDisp-24.6 {TkTextCharLayoutProc, line ends with space} {fonts} { +} [list [list 3 3 4 $fixedHeight] [list 7 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 4 $fixedHeight]] +test textDisp-24.6 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" wm geom . {} update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 7 13} {3 16 7 13}} -test textDisp-24.7 {TkTextCharLayoutProc, line ends with space} {fonts} { +} [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.7 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" wm geom . [expr $width+1]x$height update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 12 13} {3 16 7 13}} -test textDisp-24.8 {TkTextCharLayoutProc, line ends with space} {fonts} { +} [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.8 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" wm geom . [expr $width-1]x$height update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 10 13} {3 16 7 13}} -test textDisp-24.9 {TkTextCharLayoutProc, line ends with space} {fonts} { +} [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.9 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" wm geom . [expr $width-6]x$height update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 5 13} {3 16 7 13}} -test textDisp-24.10 {TkTextCharLayoutProc, line ends with space} {fonts} { +} [list [list 136 3 5 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.10 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" wm geom . [expr $width-7]x$height update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 4 13} {3 16 7 13}} -test textDisp-24.11 {TkTextCharLayoutProc, line ends with space that doesn't quite fit} {fonts} { +} [list [list 136 3 4 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.11 {TkTextCharLayoutProc, line ends with space that doesn't quite fit} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "01234567890123456789 \nabcdefg" @@ -2453,72 +2879,78 @@ test textDisp-24.11 {TkTextCharLayoutProc, line ends with space that doesn't qui lappend result [.t bbox 1.21] [.t bbox 2.0] .t mark set insert 1.21 lappend result [.t bbox 1.21] [.t bbox 2.0] -} {{145 3 0 13} {3 16 7 13} {145 3 0 13} {3 16 7 13}} -test textDisp-24.12 {TkTextCharLayoutProc, tab causes wrap} {fonts} { +} [list [list 145 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 145 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.12 {TkTextCharLayoutProc, tab causes wrap} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghi" .t mark set insert 1.4 .t insert insert \t\t\t list [.t bbox {insert -1c}] [.t bbox insert] -} {{115 3 30 13} {3 16 7 13}} -test textDisp-24.13 {TkTextCharLayoutProc, -wrap none} {fonts} { +} [list [list 115 3 30 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.13 {TkTextCharLayoutProc, -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . {} update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 7 13} {}} -test textDisp-24.14 {TkTextCharLayoutProc, -wrap none} {fonts} { +} [list [list 136 3 7 $fixedHeight] {}] +test textDisp-24.14 {TkTextCharLayoutProc, -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . [expr $width+1]x$height update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 7 13} {143 3 5 13}} -test textDisp-24.15 {TkTextCharLayoutProc, -wrap none} {fonts} { +} [list [list 136 3 7 $fixedHeight] [list 143 3 5 $fixedHeight]] +test textDisp-24.15 {TkTextCharLayoutProc, -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . [expr $width-1]x$height update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 7 13} {143 3 3 13}} -test textDisp-24.16 {TkTextCharLayoutProc, no chars fit} {fonts} { +} [list [list 136 3 7 $fixedHeight] [list 143 3 3 $fixedHeight]] +test textDisp-24.16 {TkTextCharLayoutProc, no chars fit} {textfonts} { + if {$tcl_platform(platform) == "windows"} { + wm overrideredirect . 1 + } .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . 103x$height update list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 1.2] -} {{3 3 1 13} {3 16 1 13} {3 29 1 13}} -test textDisp-24.17 {TkTextCharLayoutProc, -wrap word} {fonts} { +} [list [list 3 3 1 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 1 $fixedHeight] [list 3 [expr {2*$fixedDiff + 29}] 1 $fixedHeight]] +if {$tcl_platform(platform) == "windows"} { + wm overrideredirect . 0 +} +test textDisp-24.17 {TkTextCharLayoutProc, -wrap word} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This is a line that wraps around" wm geom . {} update list [.t bbox 1.19] [.t bbox 1.20] -} {{136 3 7 13} {3 16 7 13}} -test textDisp-24.18 {TkTextCharLayoutProc, -wrap word} {fonts} { +} [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.18 {TkTextCharLayoutProc, -wrap word} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "xThis is a line that wraps around" wm geom . {} update list [.t bbox 1.14] [.t bbox 1.15] [.t bbox 1.16] -} {{101 3 7 13} {108 3 35 13} {3 16 7 13}} -test textDisp-24.19 {TkTextCharLayoutProc, -wrap word} {fonts} { +} [list [list 101 3 7 $fixedHeight] [list 108 3 35 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] +test textDisp-24.19 {TkTextCharLayoutProc, -wrap word} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "xxThis is a line that wraps around" wm geom . {} update list [.t bbox 1.14] [.t bbox 1.15] [.t bbox 1.16] -} {{101 3 7 13} {108 3 7 13} {115 3 28 13}} -test textDisp-24.20 {TkTextCharLayoutProc, vertical offset} {fonts} { +} [list [list 101 3 7 $fixedHeight] [list 108 3 7 $fixedHeight] [list 115 3 28 $fixedHeight]] +test textDisp-24.20 {TkTextCharLayoutProc, vertical offset} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2\nLine 3" @@ -2531,18 +2963,18 @@ test textDisp-24.20 {TkTextCharLayoutProc, vertical offset} {fonts} { lappend result [.t bbox 2.1] [.t dlineinfo 2.1] .t tag delete up set result -} {{10 16 7 13} {3 16 42 13 10} {10 16 7 13} {3 16 42 19 16} {10 18 7 13} {3 16 42 15 10}} +} [list [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 19}] [expr {$fixedDiff + 16}]] [list 10 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 15}] [expr {$fixedDiff + 10}]]] .t configure -width 30 update -test textDisp-24.21 {TkTextCharLayoutProc, word breaks} {fonts} { +test textDisp-24.21 {TkTextCharLayoutProc, word breaks} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Sample text xxxxxxx yyyyy zzzzzzz qqqqq rrrr ssss tt u vvvvv" frame .t.f -width 30 -height 20 -bg black .t window create 1.36 -window .t.f .t bbox 1.26 -} {3 19 7 13} -test textDisp-24.22 {TkTextCharLayoutProc, word breaks} {fonts} { +} [list 3 [expr {$fixedDiff/2 + 19}] 7 $fixedHeight] +test textDisp-24.22 {TkTextCharLayoutProc, word breaks} {textfonts} { .t configure -wrap word .t delete 1.0 end frame .t.f -width 30 -height 20 -bg black @@ -2550,8 +2982,8 @@ test textDisp-24.22 {TkTextCharLayoutProc, word breaks} {fonts} { .t window create end -window .t.f .t insert end "zzzzzzz qqqqq rrrr ssss tt u vvvvv" .t bbox 1.28 -} {33 19 7 13} -test textDisp-24.23 {TkTextCharLayoutProc, word breaks} {fonts} { +} [list 33 [expr {$fixedDiff/2 + 19}] 7 $fixedHeight] +test textDisp-24.23 {TkTextCharLayoutProc, word breaks} {textfonts} { .t configure -wrap word .t delete 1.0 end frame .t.f -width 30 -height 20 -bg black @@ -2560,36 +2992,45 @@ test textDisp-24.23 {TkTextCharLayoutProc, word breaks} {fonts} { .t window create end -window .t.f .t insert end "u vvvvv" .t bbox .t.f -} {3 29 30 20} +} [list 3 [expr {2*$fixedDiff + 29}] 30 20] catch {destroy .t.f} .t configure -width 20 update -test textDisp-24.24 {TkTextCharLayoutProc, justification and tabs} {fonts} { +test textDisp-24.24 {TkTextCharLayoutProc, justification and tabs} {textfonts} { .t delete 1.0 end .t tag configure x -justify center .t insert 1.0 aa\tbb\tcc\tdd\t .t tag add x 1.0 end list [.t bbox 1.0] [.t bbox 1.10] -} {{45 3 7 13} {94 3 7 13}} +} [list [list 45 3 7 $fixedHeight] [list 94 3 7 $fixedHeight]] .t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \ -tabs 100 update -test textDisp-25.1 {CharBboxProc procedure, check tab width} {fonts} { +test textDisp-25.1 {CharBboxProc procedure, check tab width} {textfonts} { .t delete 1.0 end .t insert 1.0 abc\td\tfgh list [.t bbox 1.3] [.t bbox 1.5] [.t bbox 1.6] -} {{21 1 79 13} {107 1 93 13} {200 1 7 13}} +} [list [list 21 1 79 $fixedHeight] [list 107 1 93 $fixedHeight] [list 200 1 7 $fixedHeight]] .t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \ -tabs {} update -test textDisp-26.1 {AdjustForTab procedure, no tabs} {fonts} { +test textDisp-26.1 {AdjustForTab procedure, no tabs} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.12] 0] \ [lindex [.t bbox 1.14] 0] -} {56 168 224} +} [list 56 126 168] +test textDisp-26.1.2 {AdjustForTab procedure, no tabs} {textfonts} { + .t delete 1.0 end + .t insert 1.0 a\tbcdefghij\tc\td + .t configure -tabstyle wordprocessor + set res [list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.12] 0] \ + [lindex [.t bbox 1.14] 0]] + .t configure -tabstyle tabular + set res +} [list 56 168 224] test textDisp-26.2 {AdjustForTab procedure, not enough tabs specified} { .t delete 1.0 end .t insert 1.0 a\tb\tc\td @@ -2598,7 +3039,7 @@ test textDisp-26.2 {AdjustForTab procedure, not enough tabs specified} { .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] \ [lindex [.t bbox 1.6] 0] -} {40 80 120} +} [list 40 80 120] test textDisp-26.3 {AdjustForTab procedure, not enough tabs specified} { .t delete 1.0 end .t insert 1.0 a\tb\tc\td\te @@ -2609,7 +3050,7 @@ test textDisp-26.3 {AdjustForTab procedure, not enough tabs specified} { [expr [lindex [.t bbox 1.4] 0] + [lindex [.t bbox 1.4] 2]] \ [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]] \ [expr [lindex [.t bbox 1.8] 0] + [lindex [.t bbox 1.8] 2]] -} {40 70 100 130} +} [list 40 70 100 130] test textDisp-26.4 {AdjustForTab procedure, different alignments} { .t delete 1.0 end .t insert 1.0 a\tbc\tde\tfg\thi @@ -2621,7 +3062,7 @@ test textDisp-26.4 {AdjustForTab procedure, different alignments} { .t tag add y 1.8 list [lindex [.t bbox 1.3] 0] [lindex [.t bbox 1.5] 0] \ [lindex [.t bbox 1.10] 0] -} {40 80 130} +} [list 40 80 130] test textDisp-26.5 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1.234 @@ -2700,7 +3141,7 @@ test textDisp-26.12 {AdjustForTab procedure, adjusting chunks} { update lindex [.t bbox 1.5] 0 } {120} -test textDisp-26.13 {AdjustForTab procedure, not enough space} {fonts} { +test textDisp-26.13 {AdjustForTab procedure, not enough space} {textfonts} { .t delete 1.0 end .t insert 1.0 "abc\txyz\tqrs\txyz\t0" .t tag delete x @@ -2708,97 +3149,190 @@ test textDisp-26.13 {AdjustForTab procedure, not enough space} {fonts} { .t tag add x 1.0 end list [lindex [.t bbox 1.4] 0] [lindex [.t bbox 1.8] 0] \ [lindex [.t bbox 1.12] 0] [lindex [.t bbox 1.16] 0] -} {28 56 84 120} +} [list 28 56 84 120] +test textDisp-26.13.2 {AdjustForTab procedure, not enough space} {textfonts} { + .t delete 1.0 end + .t insert 1.0 "abc\txyz\tqrs\txyz\t0" + .t tag delete x + .t tag configure x -tabs {10 30 center 50 right 120} -tabstyle wordprocessor + .t tag add x 1.0 end + set res [list [lindex [.t bbox 1.4] 0] [lindex [.t bbox 1.8] 0] \ + [lindex [.t bbox 1.12] 0] [lindex [.t bbox 1.16] 0]] + .t tag configure x -tabstyle tabular + set res +} [list 28 56 120 190] +test textDisp-26.14 {AdjustForTab procedure, not enough space} {textfonts} { + .t delete 1.0 end + .t insert end "a \tb \tc \td \te \tf \tg\n" + .t insert end "Watch the \tX and the \t\t\tY\n" + .t tag configure moop -tabs [expr {8*$fixedWidth}] + .t insert end "Watch the \tX and the \t\t\tY\n" moop + list [lindex [.t bbox 2.11] 0] [lindex [.t bbox 2.24] 0] \ + [lindex [.t bbox 3.11] 0] [lindex [.t bbox 3.24] 0] +} [list 77 224 77 224] +test textDisp-26.14.2 {AdjustForTab procedure, not enough space} {textfonts} { + .t delete 1.0 end + .t configure -tabstyle wordprocessor + .t insert end "a \tb \tc \td \te \tf \tg\n" + .t insert end "Watch the \tX and the \t\t\tY\n" + .t tag configure moop -tabs [expr {8*$fixedWidth}] + .t insert end "Watch the \tX and the \t\t\tY\n" moop + set res [list [lindex [.t bbox 2.11] 0] [lindex [.t bbox 2.24] 0] \ + [lindex [.t bbox 3.11] 0] [lindex [.t bbox 3.24] 0]] + .t configure -tabstyle tabular + set res +} [list 112 56 112 56] .t configure -width 20 -bd 2 -highlightthickness 2 -relief sunken -tabs {} \ -wrap char update -test textDisp-27.1 {SizeOfTab procedure, old-style tabs} {fonts} { +test textDisp-27.1 {SizeOfTab procedure, old-style tabs} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td list [.t bbox 1.2] [.t bbox 1.10] [.t bbox 1.12] -} {{60 5 7 13} {116 5 7 13} {4 18 7 13}} -test textDisp-27.2 {SizeOfTab procedure, choosing tabX and alignment} {fonts} { +} [list [list 60 5 7 $fixedHeight] [list 116 5 7 $fixedHeight] [list 130 5 7 $fixedHeight]] +test textDisp-27.1.1 {SizeOfTab procedure, old-style tabs} {textfonts} { + .t delete 1.0 end + .t insert 1.0 a\tbcdefghij\tc\td + .t configure -tabstyle wordprocessor + set res [list [.t bbox 1.2] [.t bbox 1.10] [.t bbox 1.12]] + .t configure -tabstyle tabular + set res +} [list [list 60 5 7 $fixedHeight] [list 116 5 7 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-27.2 {SizeOfTab procedure, choosing tabX and alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcd .t tag delete x .t tag configure x -tabs 120 .t tag add x 1.0 end list [.t bbox 1.3] [.t bbox 1.4] -} {{131 5 13 13} {4 18 7 13}} -test textDisp-27.3 {SizeOfTab procedure, choosing tabX and alignment} {fonts} { +} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-27.3 {SizeOfTab procedure, choosing tabX and alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\t\t\tbcd .t tag delete x .t tag configure x -tabs 40 .t tag add x 1.0 end list [.t bbox 1.5] [.t bbox 1.6] -} {{131 5 13 13} {4 18 7 13}} -test textDisp-27.4 {SizeOfTab procedure, choosing tabX and alignment} {fonts} { +} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-27.4 {SizeOfTab procedure, choosing tabX and alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\t\t\tbcd .t tag delete x .t tag configure x -tabs {20 center 70 left} .t tag add x 1.0 end list [.t bbox 1.5] [.t bbox 1.6] -} {{131 5 13 13} {4 18 7 13}} -test textDisp-27.5 {SizeOfTab procedure, center alignment} {fonts} { +} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-27.5 {SizeOfTab procedure, center alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\txyzzyabc .t tag delete x .t tag configure x -tabs {120 center} .t tag add x 1.0 end list [.t bbox 1.6] [.t bbox 1.7] -} {{135 5 9 13} {4 18 7 13}} -test textDisp-27.6 {SizeOfTab procedure, center alignment} {fonts} { +} [list [list 135 5 9 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-27.6 {SizeOfTab procedure, center alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\txyzzyabc .t tag delete x .t tag configure x -tabs {150 center} .t tag add x 1.0 end list [.t bbox 1.6] [.t bbox 1.7] -} {{32 18 7 13} {39 18 7 13}} -test textDisp-27.7 {SizeOfTab procedure, center alignment, wrap -none (potential numerical problems)} {fonts} { +} [list [list 32 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 39 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-27.7 {SizeOfTab procedure, center alignment, wrap -none (potential numerical problems)} {textfonts} { + .t delete 1.0 end + set cm [winfo fpixels .t 1c] + .t configure -tabs {1c 2c center 3c 4c 5c 6c 7c 8c} -wrap none -width 40 + .t insert 1.0 a\tb\tc\td\te\n012345678934567890a\tbb\tcc\tdd + set width [expr {$fixedWidth * 19}] + set tab $cm + while {$tab < $width} { + set tab [expr {$tab + $cm}] + } + # Now we've calculated to the end of the tab after 'a', add one + # more for 'bb\t' and we're there, with 4 for the border. Since + # Tk_GetPixelsFromObj uses the standard 'int(0.5 + float)' rounding, + # so must we. + set tab [expr {4 + int(0.5 + $tab + $cm)}] + update + set res [.t bbox 2.23] + lset res 0 [expr {[lindex $res 0] - $tab}] + set res +} [list -28 [expr {$fixedDiff + 18}] 7 $fixedHeight] +test textDisp-27.7.1 {SizeOfTab procedure, center alignment, wrap -none (potential numerical problems)} {textfonts} { .t delete 1.0 end - .t configure -tabs {1c 2c center 3c 4c} -wrap none -width 40 + .t configure -tabstyle wordprocessor + set cm [winfo fpixels .t 1c] + .t configure -tabs {1c 2c center 3c 4c 5c 6c 7c 8c} -wrap none -width 40 .t insert 1.0 a\tb\tc\td\te\n012345678934567890a\tbb\tcc\tdd + set width [expr {$fixedWidth * 19}] + set tab $cm + while {$tab < $width} { + set tab [expr {$tab + $cm}] + } + # Now we've calculated to the end of the tab after 'a', add one + # more for 'bb\t' and we're there, with 4 for the border. Since + # Tk_GetPixelsFromObj uses the standard 'int(0.5 + float)' rounding, + # so must we. + set tab [expr {4 + int(0.5 + $tab + $cm)}] + update + set res [.t bbox 2.23] + .t configure -tabstyle tabular + lset res 0 [expr {[lindex $res 0] - $tab}] + set res +} [list 0 [expr {$fixedDiff + 18}] 7 $fixedHeight] +test textDisp-27.7.2 {SizeOfTab procedure, fractional tab interpolation problem} { + .t delete 1.0 end + set interpolatetab {1c 2c} + set precisetab {} + for {set i 1} {$i < 20} {incr i} { + lappend precisetab "${i}c" + } + .t configure -tabs $interpolatetab -wrap none -width 150 + .t insert 1.0 [string repeat "a\t" 20] update - .t bbox 2.24 -} {172 18 7 13} + set res [.t bbox 1.20] + # Now, Tk's interpolated tabs should be the same as + # non-interpolated. + .t configure -tabs $precisetab + update + expr {[lindex $res 0] - [lindex [.t bbox 1.20] 0]} +} {0} + .t configure -wrap char -tabs {} -width 20 update -test textDisp-27.8 {SizeOfTab procedure, right alignment} {fonts} { +test textDisp-27.8 {SizeOfTab procedure, right alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\t\txyzzyabc .t tag delete x .t tag configure x -tabs {100 left 140 right} .t tag add x 1.0 end list [.t bbox 1.6] [.t bbox 1.7] -} {{137 5 7 13} {4 18 7 13}} -test textDisp-27.9 {SizeOfTab procedure, left alignment} {fonts} { +} [list [list 137 5 7 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-27.9 {SizeOfTab procedure, left alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\txyzzyabc .t tag delete x .t tag configure x -tabs {120} .t tag add x 1.0 end list [.t bbox 1.3] [.t bbox 1.4] -} {{131 5 13 13} {4 18 7 13}} -test textDisp-27.10 {SizeOfTab procedure, numeric alignment} {fonts} { +} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-27.10 {SizeOfTab procedure, numeric alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\t123.4 .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end list [.t bbox 1.3] [.t bbox 1.4] -} {{117 5 27 13} {4 18 7 13}} -test textDisp-27.11 {SizeOfTab procedure, making tabs at least as wide as a space} {fonts} { +} [list [list 117 5 27 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] +test textDisp-27.11 {SizeOfTab procedure, making tabs at least as wide as a space} {textfonts} { .t delete 1.0 end .t insert 1.0 abc\tdefghijklmnopqrst .t tag delete x .t tag configure x -tabs {120} .t tag add x 1.0 end list [.t bbox 1.5] [.t bbox 1.6] -} {{131 5 13 13} {4 18 7 13}} +} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] proc bizarre_scroll args { .t2.t delete 5.0 end @@ -2818,7 +3352,7 @@ test textDisp-28.1 {"yview" option with bizarre scroll command} { lappend result [.t2.t index @0,0] } {6.0 1.0} -test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {fonts} { +test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 @@ -2832,8 +3366,8 @@ test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {fonts} { .t2.t window create 1.1 -window .t2.t.f update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] -} {{0 0.466667} 300x50+5+18 {12 68 7 13}} -test textDisp-29.2 {miscellaneous: lines wrap but are still too long} {fonts} { +} [list [list 0.0 [expr {14.0/30}]] 300x50+5+[expr {$fixedDiff + 18}] [list 12 [expr {$fixedDiff + 68}] 7 $fixedHeight]] +test textDisp-29.2 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 @@ -2848,8 +3382,99 @@ test textDisp-29.2 {miscellaneous: lines wrap but are still too long} {fonts} { .t2.t xview scroll 1 unit update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] -} {{0.0233333 0.49} 300x50+-2+18 {5 68 7 13}} -test textDisp-29.3 {miscellaneous: lines wrap but are still too long} {fonts} { +} [list [list [expr {7.0/300}] 0.49] 300x50+-2+[expr {$fixedDiff + 18}] [list 5 [expr {$fixedDiff + 68}] 7 $fixedHeight]] +test textDisp-29.2.1 {miscellaneous: lines wrap but are still too long} {textfonts} { + catch {destroy .t2} + toplevel .t2 + wm geometry .t2 +0+0 + text .t2.t -width 20 -height 10 -font $fixedFont \ + -wrap none -xscrollcommand ".t2.s set" + pack .t2.t -side top + scrollbar .t2.s -orient horizontal -command ".t2.t xview" + pack .t2.s -side bottom -fill x + .t2.t insert end 1\n + .t2.t insert end [string repeat "abc" 30] + .t2.t xview scroll 5 unit + update + .t2.t xview +} [list [expr {5.0/90}] [expr {25.0/90}]] +test textDisp-29.2.2 {miscellaneous: lines wrap but are still too long} {textfonts} { + catch {destroy .t2} + toplevel .t2 + wm geometry .t2 +0+0 + text .t2.t -width 20 -height 10 -font $fixedFont \ + -wrap char -xscrollcommand ".t2.s set" + pack .t2.t -side top + scrollbar .t2.s -orient horizontal -command ".t2.t xview" + pack .t2.s -side bottom -fill x + .t2.t insert end 123 + frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised + .t2.t window create 1.1 -window .t2.t.f + .t2.t xview scroll 2 unit + update + list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] +} [list [list [expr {14.0/300}] [expr {154.0/300}]] 300x50+-9+[expr {$fixedDiff + 18}] {}] +test textDisp-29.2.3 {miscellaneous: lines wrap but are still too long} {textfonts} { + catch {destroy .t2} + toplevel .t2 + wm geometry .t2 +0+0 + text .t2.t -width 20 -height 10 -font $fixedFont \ + -wrap char -xscrollcommand ".t2.s set" + pack .t2.t -side top + scrollbar .t2.s -orient horizontal -command ".t2.t xview" + pack .t2.s -side bottom -fill x + .t2.t insert end 123 + frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised + .t2.t window create 1.1 -window .t2.t.f + .t2.t xview scroll 7 pixels + update + list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] +} [list [list [expr {7.0/300}] 0.49] 300x50+-2+[expr {$fixedDiff + 18}] [list 5 [expr {$fixedDiff + 68}] 7 $fixedHeight]] +test textDisp-29.2.4 {miscellaneous: lines wrap but are still too long} {textfonts} { + catch {destroy .t2} + toplevel .t2 + wm geometry .t2 +0+0 + text .t2.t -width 20 -height 10 -font $fixedFont \ + -wrap char -xscrollcommand ".t2.s set" + pack .t2.t -side top + scrollbar .t2.s -orient horizontal -command ".t2.t xview" + pack .t2.s -side bottom -fill x + .t2.t insert end 123 + frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised + .t2.t window create 1.1 -window .t2.t.f + .t2.t xview scroll 17 pixels + update + list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] +} [list [list [expr {17.0/300}] [expr {157.0/300}]] 300x50+-12+[expr {$fixedDiff + 18}] {}] +test textDisp-29.2.5 {miscellaneous: can show last character} { + catch {destroy .t2} + toplevel .t2 + wm geometry .t2 121x141+200+200 + text .t2.t -width 5 -height 5 -font {Arial 10} \ + -wrap none -xscrollcommand ".t2.s set" \ + -bd 2 -highlightthickness 0 -padx 1 + .t2.t insert end "WWWWWWWWWWWWi" + scrollbar .t2.s -orient horizontal -command ".t2.t xview" + grid .t2.t -row 0 -column 0 -sticky nsew + grid .t2.s -row 1 -column 0 -sticky ew + grid columnconfigure .t2 0 -weight 1 + grid rowconfigure .t2 0 -weight 1 + grid rowconfigure .t2 1 -weight 0 + update ; update + set xv [.t2.t xview] + set xd [expr {[lindex $xv 1] - [lindex $xv 0]}] + .t2.t xview moveto [expr {1.0-$xd}] + set iWidth [lindex [.t2.t bbox end-2c] 2] + .t2.t xview scroll 2 units + set iWidth2 [lindex [.t2.t bbox end-2c] 2] + + if {($iWidth == $iWidth2) && $iWidth >= 2} { + set result "correct" + } else { + set result "last character is not completely visible when it should be" + } +} {correct} +test textDisp-29.3 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 @@ -2865,9 +3490,337 @@ test textDisp-29.3 {miscellaneous: lines wrap but are still too long} {fonts} { .t2.t xview scroll 200 units update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] -} {{0.536667 1} 300x50+-156+18 {}} +} [list [list [expr {16.0/30}] 1.0] 300x50+-155+[expr {$fixedDiff + 18}] {}] +test textDisp-30.1 {elidden text joining multiple logical lines} { + .t2.t delete 1.0 end + .t2.t insert 1.0 "1111\n2222\n3333" + .t2.t tag configure elidden -elide 1 -background red + .t2.t tag add elidden 1.2 3.2 + .t2.t count -displaylines 1.0 end +} {1} +test textDisp-30.2 {elidden text joining multiple logical lines} { + .t2.t delete 1.0 end + .t2.t insert 1.0 "1111\n2222\n3333" + .t2.t tag configure elidden -elide 1 -background red + .t2.t tag add elidden 1.2 2.2 + .t2.t count -displaylines 1.0 end +} {2} +catch {destroy .t2} + +.t configure -height 1 +update + +test textDisp-31.1 {line embedded window height update} { + set res {} + .t delete 1.0 end + .t insert end "abcd\nefgh\nijkl\nmnop\nqrst\nuvwx\nyx" + frame .t.f -background red -width 100 -height 100 + .t window create 3.0 -window .t.f + lappend res [.t count -update -ypixels 1.0 end] + .t.f configure -height 10 + lappend res [.t count -ypixels 1.0 end] + lappend res [.t count -update -ypixels 1.0 end] + set res +} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 6}] [expr {$fixedHeight * 7}]] + +test textDisp-31.2 {line update index shifting} { + set res {} + .t.f configure -height 100 + update + lappend res [.t count -update -ypixels 1.0 end] + .t.f configure -height 10 + .t insert 1.0 "abc\n" + .t insert 1.0 "abc\n" + lappend res [.t count -ypixels 1.0 end] + lappend res [.t count -update -ypixels 1.0 end] + .t.f configure -height 100 + .t delete 1.0 3.0 + lappend res [.t count -ypixels 1.0 end] + lappend res [.t count -update -ypixels 1.0 end] + set res +} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]] + +test textDisp-31.3 {line update index shifting} { + # Should do exactly the same as the above, as long + # as we are correctly tagging the correct lines for + # recalculation. The 'update' and 'delay' must be + # long enough to ensure all asynchronous updates + # have been performed. + set res {} + .t.f configure -height 100 + update + lappend res [.t count -update -ypixels 1.0 end] + .t.f configure -height 10 + .t insert 1.0 "abc\n" + .t insert 1.0 "abc\n" + lappend res [.t count -ypixels 1.0 end] + update ; after 1000 ; update + lappend res [.t count -ypixels 1.0 end] + .t.f configure -height 100 + .t delete 1.0 3.0 + lappend res [.t count -ypixels 1.0 end] + update ; after 1000 ; update + lappend res [.t count -ypixels 1.0 end] + set res +} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]] + +test textDisp-31.4 {line embedded image height update} { + set res {} + image create photo textest -height 100 -width 10 + .t delete 3.0 + .t image create 3.0 -image textest + update + lappend res [.t count -update -ypixels 1.0 end] + textest configure -height 10 + lappend res [.t count -ypixels 1.0 end] + lappend res [.t count -update -ypixels 1.0 end] + set res +} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 6}] [expr {$fixedHeight * 7}]] + +test textDisp-31.5 {line update index shifting} { + set res {} + textest configure -height 100 + update ; after 1000 ; update + lappend res [.t count -update -ypixels 1.0 end] + textest configure -height 10 + .t insert 1.0 "abc\n" + .t insert 1.0 "abc\n" + lappend res [.t count -ypixels 1.0 end] + lappend res [.t count -update -ypixels 1.0 end] + textest configure -height 100 + .t delete 1.0 3.0 + lappend res [.t count -ypixels 1.0 end] + lappend res [.t count -update -ypixels 1.0 end] + set res +} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]] + +test textDisp-31.6 {line update index shifting} { + # Should do exactly the same as the above, as long + # as we are correctly tagging the correct lines for + # recalculation. The 'update' and 'delay' must be + # long enough to ensure all asynchronous updates + # have been performed. + set res {} + textest configure -height 100 + update ; after 1000 ; update + lappend res [.t count -update -ypixels 1.0 end] + textest configure -height 10 + .t insert 1.0 "abc\n" + .t insert 1.0 "abc\n" + lappend res [.t count -ypixels 1.0 end] + update ; after 1000 ; update + lappend res [.t count -ypixels 1.0 end] + textest configure -height 100 + .t delete 1.0 3.0 + lappend res [.t count -ypixels 1.0 end] + update ; after 1000 ; update + lappend res [.t count -ypixels 1.0 end] + set res +} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]] -test textDisp-33.5 {bold or italic fonts} {winOnly} { +test textDisp-31.7 {line update index shifting, elided} { + # The 'update' and 'delay' must be long enough to ensure all + # asynchronous updates have been performed. + set res {} + .t delete 1.0 end + lappend res [.t count -update -ypixels 1.0 end] + .t insert 1.0 "abc\nabc" + .t insert 1.0 "abc\n" + lappend res [.t count -update -ypixels 1.0 end] + .t tag configure elide -elide 1 + .t tag add elide 1.3 2.1 + lappend res [.t count -ypixels 1.0 end] + update ; after 1000 ; update + lappend res [.t count -ypixels 1.0 end] + .t delete 1.0 3.0 + lappend res [.t count -ypixels 1.0 end] + update ; after 1000 ; update + lappend res [.t count -ypixels 1.0 end] + set res +} [list [expr {$fixedHeight * 1}] [expr {$fixedHeight * 3}] [expr {$fixedHeight * 3}] [expr {$fixedHeight * 2}] [expr {$fixedHeight * 1}] [expr {$fixedHeight * 1}]] + +test textDisp-32.0 {everything elided} { + # Must not crash + pack [text .tt] + .tt insert 0.0 HELLO + .tt tag configure HIDE -elide 1 + .tt tag add HIDE 0.0 end + update ; update ; update ; update + destroy .tt +} {} +test textDisp-32.1 {everything elided} { + # Must not crash + pack [text .tt] + update + .tt insert 0.0 HELLO + update + .tt tag configure HIDE -elide 1 + update + .tt tag add HIDE 0.0 end + update ; update ; update ; update + destroy .tt +} {} +test textDisp-32.2 {elide and tags} { + pack [text .tt -height 30 -width 100 -bd 0 \ + -highlightthickness 0 -padx 0] + .tt insert end \ + {test text using tags 1 and 3 } \ + {testtag1 testtag3} \ + {[this bit here uses tags 2 and 3]} \ + {testtag2 testtag3} + update + # indent left margin of tag 1 by 20 pixels + # text should be indented + .tt tag configure testtag1 -lmargin1 20 ; update + #1 + set res {} + lappend res [list [.tt index "1.0 + 0 displaychars"] \ + [lindex [.tt bbox 1.0] 0] \ + [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] + # hide tag 1, remaining text should not be indented, since + # the indented tag and character is hidden. + .tt tag configure testtag1 -elide 1 ; update + #2 + lappend res [list [.tt index "1.0 + 0 displaychars"] \ + [lindex [.tt bbox 1.0] 0] \ + [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] + # reset + .tt tag configure testtag1 -lmargin1 0 + .tt tag configure testtag1 -elide 0 + # indent left margin of tag 2 by 20 pixels + # text should not be indented, since tag1 has lmargin1 of 0. + .tt tag configure testtag2 -lmargin1 20 ; update + #3 + lappend res [list [.tt index "1.0 + 0 displaychars"] \ + [lindex [.tt bbox 1.0] 0] \ + [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] + # hide tag 1, remaining text should now be indented, but + # the bbox of 1.0 should have zero width and zero indent, + # since it is elided at that position. + .tt tag configure testtag1 -elide 1 ; update + #4 + lappend res [list [.tt index "1.0 + 0 displaychars"] \ + [lindex [.tt bbox 1.0] 0] \ + [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] + # reset + .tt tag configure testtag2 -lmargin1 {} + .tt tag configure testtag1 -elide 0 + # indent left margin of tag 3 by 20 pixels + # text should be indented, since this tag takes + # precedence over testtag1, and is applied to the + # start of the text. + .tt tag configure testtag3 -lmargin1 20 ; update + #5 + lappend res [list [.tt index "1.0 + 0 displaychars"] \ + [lindex [.tt bbox 1.0] 0] \ + [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] + # hide tag 1, remaining text should still be indented, + # since it still has testtag3 on it. Again the + # bbox of 1.0 should have 0. + .tt tag configure testtag1 -elide 1 ; update + #6 + lappend res [list [.tt index "1.0 + 0 displaychars"] \ + [lindex [.tt bbox 1.0] 0] \ + [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] + .tt tag configure testtag3 -lmargin1 {} -elide 0 + .tt tag configure testtag1 -elide 1 -lmargin1 20 + #7 + lappend res [list [.tt index "1.0 + 0 displaychars"] \ + [lindex [.tt bbox 1.0] 0] \ + [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] + destroy .tt + set res +} {{1.0 20 20} {1.29 0 0} {1.0 0 0} {1.29 0 20}\ + {1.0 20 20} {1.29 0 20} {1.0 20 20}} +test textDisp-32.3 "NULL undisplayProc problems: #1791052" -setup { + set img [image create photo -data { + R0lGODlhEgASANUAAAAAAP/////iHP/mIPrWDPraEP/eGPfOAPbKAPbOBPrS + CP/aFPbGAPLCAPLGAN62ANauAMylAPbCAPW/APK+AN6uALKNAPK2APK5ANal + AOyzArGHBZp3B+6uAHFVBFVACO6qAOqqAOalAMGMAbF+Am1QBG5QBeuiAOad + AM6NAJ9vBW1MBFlACFQ9CVlBCuaZAOKVANyVAZlpBMyFAKZtBJVhBEAUEP// + /wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADcALAAAAAASABIAAAa+ + wJtw+Ckah0iiZwNhODKk0icp/HAShEKBoEBgVFOkK0Iw2GyCs+BAGbGIlrIt + EJjXBYgL6X3zJMx1Z2d3EyEmNx9xaYGCdwgaNEUPBYt0do4XKUUOlAOCnmcD + CwcXMZsEAgOqq6oLBY+mHxUKBqysCwQSIDNFJAidtgKjFyeRfRQHB2ipAmZs + IDArVSTIyoI2bB0oxkIsIxcNyeIXICh7SR8yIhoXFxogJzE1YegrNCkoLzM0 + K/RUiEY+tKASBAA7 + }] + destroy .tt +} -body { + text .tt + .tt tag configure emoticon -elide 1 + .tt insert end X + .tt mark set MSGLEFT "end - 1 char" + .tt mark gravity MSGLEFT left + .tt insert end ":)" emoticon + .tt image create end -image $img + pack .tt + update; update; update +} -cleanup { + image delete $img + destroy .tt +} + +test textDisp-33.0 {one line longer than fits in the widget} { + pack [text .tt -wrap char] + .tt insert 1.0 [string repeat "more wrap + " 300] + update ; update ; update + .tt see 1.0 + lindex [.tt yview] 0 +} {0.0} +test textDisp-33.1 {one line longer than fits in the widget} { + destroy .tt + pack [text .tt -wrap char] + .tt insert 1.0 [string repeat "more wrap + " 300] + update ; update ; update + .tt yview "1.0 +1 displaylines" + if {[lindex [.tt yview] 0] > 0.1} { + set result "window should be scrolled to the top" + } else { + set result "ok" + } +} {ok} +test textDisp-33.2 {one line longer than fits in the widget} { + destroy .tt + pack [text .tt -wrap char] + .tt debug 1 + set tk_textHeightCalc "" + .tt insert 1.0 [string repeat "more wrap + " 1] + after 100 ; update + # Nothing should have been recalculated. + set tk_textHeightCalc +} {} +test textDisp-33.3 {one line longer than fits in the widget} { + destroy .tt + pack [text .tt -wrap char] + .tt debug 1 + set tk_textHeightCalc "" + .tt insert 1.0 [string repeat "more wrap + " 300] + update ; .tt count -update -ypixels 1.0 end ; update + # Each line should have been recalculated just once + .tt debug 0 + expr {[llength $tk_textHeightCalc] == [.tt count -displaylines 1.0 end]} +} {1} +test textDisp-33.4 {one line longer than fits in the widget} { + destroy .tt + pack [text .tt -wrap char] + .tt debug 1 + set tk_textHeightCalc "" + .tt insert 1.0 [string repeat "more wrap + " 300] + update ; update ; update + set idx [.tt index "1.0 + 1 displaylines"] + .tt yview $idx + if {[lindex [.tt yview] 0] > 0.1} { + set result "window should be scrolled to the top" + } else { + set result "ok" + } + set idx [.tt index "1.0 + 1 displaylines"] + .tt debug 0 + set result +} {ok} +destroy .tt +test textDisp-33.5 {bold or italic fonts} win { destroy .tt pack [text .tt -wrap char -font {{MS Sans Serif} 15}] font create no -family [lindex [.tt cget -font] 0] -size 24 @@ -2891,9 +3844,33 @@ test textDisp-33.5 {bold or italic fonts} {winOnly} { } {italic font measurement ok} destroy .tt +test textDisp-34.1 {Text widgets multi-scrolling problem: Bug 2677890} -setup { + pack [text .t1 -width 10 -yscrollcommand {.sy set}] \ + [ttk::scrollbar .sy -orient vertical -command {.t1 yview}] \ + -side left -fill both + bindtags .sy {}; # No clicky! + set txt "" + for {set i 0} {$i < 99} {incr i} { + lappend txt "$i" [list pc $i] "\n" "" + } + set result {} +} -body { + .t1 insert end {*}$txt + update + lappend result [.sy get] + .t1 replace 6.0 6.0+1c "*" + lappend result [.sy get] + after 0 {lappend result [.sy get]} + after 1000 {lappend result [.sy get]} + vwait result;vwait result + return $result +} -cleanup { + destroy .t1 .sy +} -result {{0.0 1.0} {0.0 1.0} {0.0 1.0} {0.0 0.24}} + deleteWindows option clear # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/textImage.test b/tests/textImage.test index e6bdda2..bb5909c 100644 --- a/tests/textImage.test +++ b/tests/textImage.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # One time setup. Create a font to insure the tests are font metric invariant. @@ -33,7 +30,7 @@ test textImage-1.2 {basic argument checking} { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t list [catch {.t image c} msg] $msg -} {1 {bad image option "c": must be cget, configure, create, or names}} +} {1 {ambiguous option "c": must be cget, configure, create, or names}} test textImage-1.3 {cget argument checking} { catch {destroy .t} @@ -133,7 +130,7 @@ test textImage-1.14 {basic argument checking} { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t list [catch {.t image huh} msg] $msg -} {1 {bad image option "huh": must be cget, configure, create, or names}} +} {1 {bad option "huh": must be cget, configure, create, or names}} test textImage-1.15 {align argument checking} { catch { @@ -144,7 +141,7 @@ test textImage-1.15 {align argument checking} { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t list [catch {.t image create end -image small -align wrong} msg] $msg -} {1 {bad alignment "wrong": must be baseline, bottom, center, or top}} +} {1 {bad align "wrong": must be baseline, bottom, center, or top}} test textImage-1.16 {configure} { catch { @@ -303,7 +300,9 @@ test textImage-4.2 {alignment checking - baseline} { .t image create end -image small -align baseline .t insert end test set result "" - foreach size {10 15 20 30} { + # Sizes larger than 25 can be too big and lead to a negative 'norm', + # at least on Windows XP with certain settings. + foreach size {10 15 20 25} { font configure test_font2 -size $size array set Metrics [font metrics test_font2] update @@ -317,7 +316,7 @@ test textImage-4.2 {alignment checking - baseline} { font delete test_font2 unset Metrics set result -} {{10 0} {15 0} {20 0} {30 0}} +} {{10 0} {15 0} {20 0} {25 0}} test textImage-4.3 {alignment and padding checking} {fonts} { catch { @@ -342,25 +341,30 @@ test textImage-4.3 {alignment and padding checking} {fonts} { } set result } {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}} -# cleanup +test textImage-5.0 {peer widget images} { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + image create photo large -width 50 -height 50 + large put green -to 0 0 50 50 + } + catch {destroy .t .tt} + pack [text .t] + toplevel .tt + pack [.t peer create .tt.t] + .t image create end -image large + .t image create end -image small -padx 5 -pady 10 + .t insert end test + update + destroy .t .tt +} {} + +# cleanup catch {destroy .t} foreach image [image names] {image delete $image} font delete test_font # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/textIndex.test b/tests/textIndex.test index 0337fca..6341b6d 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -7,14 +7,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands - -# Some tests require the testtext command -testConstraint testtext [llength [info commands testtext]] +namespace import -force tcltest::test catch {destroy .t} text .t -font {Courier -12} -width 20 -height 10 @@ -646,7 +641,7 @@ test textIndex-15.15 {StartEnd} { list [catch {.t index {2.12 word}} msg] $msg } {1 {bad text index "2.12 word"}} -test testIndex-16.1 {TkTextPrintIndex} { +test textIndex-16.1 {TkTextPrintIndex} { set t [text .t2] $t insert end \n $t window create end -window [button $t.b] @@ -655,8 +650,7 @@ test testIndex-16.1 {TkTextPrintIndex} { catch {destroy $t} } 0 - -test testIndex-16.2 {TkTextPrintIndex} { +test textIndex-16.2 {TkTextPrintIndex} { set t [text .t2] $t insert end \n $t window create end -window [button $t.b] @@ -665,6 +659,231 @@ test testIndex-16.2 {TkTextPrintIndex} { catch {destroy $t} } 0 +test textIndex-17.1 {Object indices} { + set res {} + set t [text .t2 -height 20] + for {set i 0} {$i < 100} {incr i} { + $t insert end $i\n + } + pack $t + update + set idx @0,0 + lappend res $idx [$t index $idx] + $t yview scroll 2 pages + lappend res $idx [$t index $idx] + catch {destroy $t} + unset i + unset idx + list $res +} {{@0,0 1.0 @0,0 37.0}} + +test textIndex-18.1 {Object indices don't cache mark names} { + set res {} + text .t2 + .t2 insert 1.0 1234\n1234\n1234 + set pos "insert" + lappend res [.t2 index $pos] + .t2 mark set $pos 3.0 + lappend res [.t2 index $pos] + .t2 mark set $pos 1.0 + lappend res [.t2 index $pos] + catch {destroy .t2} + set res +} {3.4 3.0 1.0} + +frame .f -width 100 -height 20 +pack append . .f left + +set fixedFont {Courier -12} +set fixedHeight [font metrics $fixedFont -linespace] +set fixedWidth [font measure $fixedFont m] + +set varFont {Times -14} +set bigFont {Helvetica -24} +destroy .t +text .t -font $fixedFont -width 20 -height 10 -wrap char +pack append . .t {top expand fill} +.t tag configure big -font $bigFont +.t debug on +wm geometry . {} + +# 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. + +wm withdraw . +wm minsize . 1 1 +wm positionfrom . user +wm deiconify . +update + +# Some window managers (like olwm under SunOS 4.1.3) misbehave in a way +# that tends to march windows off the top and left of the screen. If +# this happens, some tests will fail because parts of the window will +# not need to be displayed (because they're off-screen). To keep this +# from happening, move the window if it's getting near the left or top +# edges of the screen. + +if {([winfo rooty .] < 50) || ([winfo rootx .] < 50)} { + wm geom . +50+50 +} + +set str [string repeat "hello " 20] + +.t insert end "$str one two three four five six seven height nine ten\n" +.t insert end "$str one two three four five six seven height nine ten\n" +.t insert end "$str one two three four five six seven height nine ten\n" + +test textIndex-19.1 {Display lines} { + .t index "2.7 displaylinestart" +} {2.0} + +test textIndex-19.2 {Display lines} { + .t index "2.7 displaylineend" +} {2.19} + +test textIndex-19.3 {Display lines} { + .t index "2.30 displaylinestart" +} {2.20} + +test textIndex-19.4 {Display lines} { + .t index "2.30 displaylineend" +} {2.39} + +test textIndex-19.5 {Display lines} { + .t index "2.40 displaylinestart" +} {2.40} + +test textIndex-19.6 {Display lines} { + .t index "2.40 displaylineend" +} {2.59} + +test textIndex-19.7 {Display lines} { + .t index "2.7 +1displaylines" +} {2.27} + +test textIndex-19.8 {Display lines} { + .t index "2.7 -1displaylines" +} {1.167} + +test textIndex-19.9 {Display lines} { + .t index "2.30 +1displaylines" +} {2.50} + +test textIndex-19.10 {Display lines} { + .t index "2.30 -1displaylines" +} {2.10} + +test textIndex-19.11 {Display lines} { + .t index "2.40 +1displaylines" +} {2.60} + +test textIndex-19.12 {Display lines} { + .t index "2.40 -1displaylines" +} {2.20} + +test textIndex-19.13 {Display lines} { + destroy .t + text .txt -height 1 -wrap word -yscroll ".sbar set" -width 400 + scrollbar .sbar -command ".txt yview" + grid .txt .sbar -sticky news + grid configure .sbar -sticky ns + grid rowconfigure . 0 -weight 1 + grid columnconfigure . 0 -weight 1 + .txt configure -width 10 + .txt tag config STAMP -elide 1 + .txt tag config NICK-tick -elide 0 + .txt insert end "+++++ Loading History ++++++++++++++++\n" + .txt mark set HISTORY {2.0 - 1 line} + .txt insert HISTORY { } STAMP + .txt insert HISTORY {tick } {NICK NICK-tick} + .txt insert HISTORY "\n" {NICK NICK-tick} + .txt insert HISTORY {[23:51] } STAMP + .txt insert HISTORY "\n" {NICK NICK-tick} + # Must not crash + .txt index "2.0 - 2 display lines" + destroy .txt .sbar +} {} + +proc text_test_word {startend chars start} { + destroy .t + text .t + .t insert end $chars + if {[regexp {end} $start]} { + set start [.t index "${start}chars -2c"] + } else { + set start [.t index "1.0 + ${start}chars"] + } + if {[.t compare $start >= "end-1c"]} { + set start "end-2c" + } + set res [.t index "$start $startend"] + .t count 1.0 $res +} + +# Following tests copied from tests from string wordstart/end in Tcl + +test textIndex-21.4 {text index wordend} { + text_test_word wordend abc. -1 +} 3 +test textIndex-21.5 {text index wordend} { + text_test_word wordend abc. 100 +} 4 +test textIndex-21.6 {text index wordend} { + text_test_word wordend "word_one two three" 2 +} 8 +test textIndex-21.7 {text index wordend} { + text_test_word wordend "one .&# three" 5 +} 6 +test textIndex-21.8 {text index wordend} { + text_test_word worde "x.y" 0 +} 1 +test textIndex-21.9 {text index wordend} { + text_test_word worde "x.y" end-1 +} 2 +test textIndex-21.10 {text index wordend, unicode} { + text_test_word wordend "xyz\u00c7de fg" 0 +} 6 +test textIndex-21.11 {text index wordend, unicode} { + text_test_word wordend "xyz\uc700de fg" 0 +} 6 +test textIndex-21.12 {text index wordend, unicode} { + text_test_word wordend "xyz\u203fde fg" 0 +} 6 +test textIndex-21.13 {text index wordend, unicode} { + text_test_word wordend "xyz\u2045de fg" 0 +} 3 +test textIndex-21.14 {text index wordend, unicode} { + text_test_word wordend "\uc700\uc700 abc" 8 +} 6 + +test textIndex-22.5 {text index wordstart} { + text_test_word wordstart "one two three_words" 400 +} 8 +test textIndex-22.6 {text index wordstart} { + text_test_word wordstart "one two three_words" 2 +} 0 +test textIndex-22.7 {text index wordstart} { + text_test_word wordstart "one two three_words" -2 +} 0 +test textIndex-22.8 {text index wordstart} { + text_test_word wordstart "one .*&^ three" 6 +} 6 +test textIndex-22.9 {text index wordstart} { + text_test_word wordstart "one two three" 4 +} 4 +test textIndex-22.10 {text index wordstart} { + text_test_word wordstart "one two three" end-5 +} 7 +test textIndex-22.11 {text index wordstart, unicode} { + text_test_word wordstart "one tw\u00c7o three" 7 +} 4 +test textIndex-22.12 {text index wordstart, unicode} { + text_test_word wordstart "ab\uc700\uc700 cdef ghi" 12 +} 10 +test textIndex-22.13 {text index wordstart, unicode} { + text_test_word wordstart "\uc700\uc700 abc" 8 +} 3 + test textIndex-23.1 {text paragraph start} { pack [text .t2] .t2 insert end " Text" @@ -676,21 +895,19 @@ test textIndex-23.1 {text paragraph start} { set res } {2.0 1.1 1.1} +test textIndex-24.1 {text mark prev} { + pack [text .t2] + .t2 insert end [string repeat "1 2 3 4 5 6 7 8 9 0\n" 12] + .t2 mark set 1.0 10.0 + update + # then this crash Tk: + set res [.t2 mark previous 10.10] + destroy .t2 + set res +} {1.0} + # cleanup rename textimage {} catch {destroy .t} -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/textMark.test b/tests/textMark.test index a95edd0..c2810cc 100644 --- a/tests/textMark.test +++ b/tests/textMark.test @@ -7,16 +7,14 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands catch {destroy .t} -testConstraint courier12 [expr {[catch { - text .t -font {Courier 12} -width 20 -height 10 - }] == 0}] +text .t -width 20 -height 10 +testConstraint haveCourier12 [expr {[catch { + .t configure -font {Courier 12} +}] == 0}] pack append . .t {top expand fill} update .t debug on @@ -39,83 +37,83 @@ bOy GIrl .#@? x_yz !@#$% Line 7" -test textMark-1.1 {TkTextMarkCmd - missing option} courier12 { +test textMark-1.1 {TkTextMarkCmd - missing option} haveCourier12 { list [catch {.t mark} msg] $msg } {1 {wrong # args: should be ".t mark option ?arg arg ...?"}} -test textMark-1.2 {TkTextMarkCmd - bogus option} courier12 { +test textMark-1.2 {TkTextMarkCmd - bogus option} haveCourier12 { list [catch {.t mark gorp} msg] $msg } {1 {bad mark option "gorp": must be gravity, names, next, previous, set, or unset}} -test textMark-1.3 {TkTextMarkCmd - "gravity" option} courier12 { +test textMark-1.3 {TkTextMarkCmd - "gravity" option} haveCourier12 { list [catch {.t mark gravity foo} msg] $msg } {1 {there is no mark named "foo"}} -test textMark-1.4 {TkTextMarkCmd - "gravity" option} courier12 { +test textMark-1.4 {TkTextMarkCmd - "gravity" option} haveCourier12 { .t mark unset x .t mark set x 1.3 .t insert 1.3 x list [.t mark gravity x] [.t index x] } {right 1.4} -test textMark-1.5 {TkTextMarkCmd - "gravity" option} courier12 { +test textMark-1.5 {TkTextMarkCmd - "gravity" option} haveCourier12 { .t mark unset x .t mark set x 1.3 .t mark g x left .t insert 1.3 x list [.t mark gravity x] [.t index x] } {left 1.3} -test textMark-1.6 {TkTextMarkCmd - "gravity" option} courier12 { +test textMark-1.6 {TkTextMarkCmd - "gravity" option} haveCourier12 { .t mark unset x .t mark set x 1.3 .t mark gravity x right .t insert 1.3 x list [.t mark gravity x] [.t index x] } {right 1.4} -test textMark-1.7 {TkTextMarkCmd - "gravity" option} courier12 { +test textMark-1.7 {TkTextMarkCmd - "gravity" option} haveCourier12 { list [catch {.t mark gravity x gorp} msg] $msg } {1 {bad mark gravity "gorp": must be left or right}} -test textMark-1.8 {TkTextMarkCmd - "gravity" option} courier12 { +test textMark-1.8 {TkTextMarkCmd - "gravity" option} haveCourier12 { list [catch {.t mark gravity} msg] $msg } {1 {wrong # args: should be ".t mark gravity markName ?gravity?"}} -test textMark-2.1 {TkTextMarkCmd - "names" option} courier12 { +test textMark-2.1 {TkTextMarkCmd - "names" option} haveCourier12 { list [catch {.t mark names 2} msg] $msg } {1 {wrong # args: should be ".t mark names"}} .t mark unset x -test textMark-2.2 {TkTextMarkCmd - "names" option} courier12 { - lsort [.t mark n] +test textMark-2.2 {TkTextMarkCmd - "names" option} haveCourier12 { + lsort [.t mark na] } {current insert} -test textMark-2.3 {TkTextMarkCmd - "names" option} courier12 { +test textMark-2.3 {TkTextMarkCmd - "names" option} haveCourier12 { .t mark set a 1.1 .t mark set "b c" 2.3 lsort [.t mark names] } {a {b c} current insert} -test textMark-3.1 {TkTextMarkCmd - "set" option} courier12 { +test textMark-3.1 {TkTextMarkCmd - "set" option} haveCourier12 { list [catch {.t mark set a} msg] $msg } {1 {wrong # args: should be ".t mark set markName index"}} -test textMark-3.2 {TkTextMarkCmd - "set" option} courier12 { +test textMark-3.2 {TkTextMarkCmd - "set" option} haveCourier12 { list [catch {.t mark s a b c} msg] $msg } {1 {wrong # args: should be ".t mark set markName index"}} -test textMark-3.3 {TkTextMarkCmd - "set" option} courier12 { +test textMark-3.3 {TkTextMarkCmd - "set" option} haveCourier12 { list [catch {.t mark set a @x} msg] $msg } {1 {bad text index "@x"}} -test textMark-3.4 {TkTextMarkCmd - "set" option} courier12 { +test textMark-3.4 {TkTextMarkCmd - "set" option} haveCourier12 { .t mark set a 1.2 .t index a } 1.2 -test textMark-3.5 {TkTextMarkCmd - "set" option} courier12 { +test textMark-3.5 {TkTextMarkCmd - "set" option} haveCourier12 { .t mark set a end .t index a } {8.0} -test textMark-4.1 {TkTextMarkCmd - "unset" option} courier12 { +test textMark-4.1 {TkTextMarkCmd - "unset" option} haveCourier12 { list [catch {.t mark unset} msg] $msg } {0 {}} -test textMark-4.2 {TkTextMarkCmd - "unset" option} courier12 { +test textMark-4.2 {TkTextMarkCmd - "unset" option} haveCourier12 { .t mark set a 1.2 .t mark set b 2.3 .t mark unset a b list [catch {.t index a} msg] $msg [catch {.t index b} msg2] $msg2 } {1 {bad text index "a"} 1 {bad text index "b"}} -test textMark-4.3 {TkTextMarkCmd - "unset" option} courier12 { +test textMark-4.3 {TkTextMarkCmd - "unset" option} haveCourier12 { .t mark set a 1.2 .t mark set b 2.3 .t mark set 49ers 3.1 @@ -123,14 +121,14 @@ test textMark-4.3 {TkTextMarkCmd - "unset" option} courier12 { lsort [.t mark names] } {current insert} -test textMark-5.1 {TkTextMarkCmd - miscellaneous} courier12 { +test textMark-5.1 {TkTextMarkCmd - miscellaneous} haveCourier12 { list [catch {.t mark} msg] $msg } {1 {wrong # args: should be ".t mark option ?arg arg ...?"}} -test textMark-5.2 {TkTextMarkCmd - miscellaneous} courier12 { +test textMark-5.2 {TkTextMarkCmd - miscellaneous} haveCourier12 { list [catch {.t mark foo} msg] $msg } {1 {bad mark option "foo": must be gravity, names, next, previous, set, or unset}} -test textMark-6.1 {TkTextMarkSegToIndex} courier12 { +test textMark-6.1 {TkTextMarkSegToIndex} haveCourier12 { .t mark set a 1.2 .t mark set b 1.2 .t mark set c 1.2 @@ -139,79 +137,79 @@ test textMark-6.1 {TkTextMarkSegToIndex} courier12 { } {1.2 1.2 1.2 1.4} catch {eval {.t mark unset} [.t mark names]} -test textMark-7.1 {MarkFindNext - invalid mark name} courier12 { +test textMark-7.1 {MarkFindNext - invalid mark name} haveCourier12 { catch {.t mark next bogus} x set x } {bad text index "bogus"} -test textMark-7.2 {MarkFindNext - marks at same location} courier12 { +test textMark-7.2 {MarkFindNext - marks at same location} haveCourier12 { .t mark set insert 2.0 .t mark set current 2.0 .t mark next current } {insert} -test textMark-7.3 {MarkFindNext - numerical starting mark} courier12 { +test textMark-7.3 {MarkFindNext - numerical starting mark} haveCourier12 { .t mark set current 1.0 .t mark set insert 1.0 .t mark next 1.0 } {insert} -test textMark-7.4 {MarkFindNext - mark on the same line} courier12 { +test textMark-7.4 {MarkFindNext - mark on the same line} haveCourier12 { .t mark set current 1.0 .t mark set insert 1.1 .t mark next current } {insert} -test textMark-7.5 {MarkFindNext - mark on the next line} courier12 { +test textMark-7.5 {MarkFindNext - mark on the next line} haveCourier12 { .t mark set current 1.end .t mark set insert 2.0 .t mark next current } {insert} -test textMark-7.6 {MarkFindNext - mark far away} courier12 { +test textMark-7.6 {MarkFindNext - mark far away} haveCourier12 { .t mark set current 1.2 .t mark set insert 7.0 .t mark next current } {insert} -test textMark-7.7 {MarkFindNext - mark on top of end} courier12 { +test textMark-7.7 {MarkFindNext - mark on top of end} haveCourier12 { .t mark set current end .t mark next end } {current} -test textMark-7.8 {MarkFindNext - no next mark} courier12 { +test textMark-7.8 {MarkFindNext - no next mark} haveCourier12 { .t mark set current 1.0 .t mark set insert 3.0 .t mark next insert } {} -test textMark-8.1 {MarkFindPrev - invalid mark name} courier12 { +test textMark-8.1 {MarkFindPrev - invalid mark name} haveCourier12 { catch {.t mark prev bogus} x set x } {bad text index "bogus"} -test textMark-8.2 {MarkFindPrev - marks at same location} courier12 { +test textMark-8.2 {MarkFindPrev - marks at same location} haveCourier12 { .t mark set insert 2.0 .t mark set current 2.0 .t mark prev insert } {current} -test textMark-8.3 {MarkFindPrev - numerical starting mark} courier12 { +test textMark-8.3 {MarkFindPrev - numerical starting mark} haveCourier12 { .t mark set current 1.0 .t mark set insert 1.0 .t mark prev 1.1 } {current} -test textMark-8.4 {MarkFindPrev - mark on the same line} courier12 { +test textMark-8.4 {MarkFindPrev - mark on the same line} haveCourier12 { .t mark set current 1.0 .t mark set insert 1.1 .t mark prev insert } {current} -test textMark-8.5 {MarkFindPrev - mark on the previous line} courier12 { +test textMark-8.5 {MarkFindPrev - mark on the previous line} haveCourier12 { .t mark set current 1.end .t mark set insert 2.0 .t mark prev insert } {current} -test textMark-8.6 {MarkFindPrev - mark far away} courier12 { +test textMark-8.6 {MarkFindPrev - mark far away} haveCourier12 { .t mark set current 1.2 .t mark set insert 7.0 .t mark prev insert } {current} -test textMark-8.7 {MarkFindPrev - mark on top of end} courier12 { +test textMark-8.7 {MarkFindPrev - mark on top of end} haveCourier12 { .t mark set insert 3.0 .t mark set current end .t mark prev end } {insert} -test textMark-8.8 {MarkFindPrev - no previous mark} courier12 { +test textMark-8.8 {MarkFindPrev - no previous mark} haveCourier12 { .t mark set current 1.0 .t mark set insert 3.0 .t mark prev current @@ -220,18 +218,5 @@ test textMark-8.8 {MarkFindPrev - no previous mark} courier12 { catch {destroy .t} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/textTag.test b/tests/textTag.test index fc4ed04..b112fc2 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -7,17 +7,15 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test catch {destroy .t} -testConstraint courier12 [expr {[catch { - text .t -font {Courier 12} -width 20 -height 10 - }] == 0}] - +text .t -width 20 -height 10 +testConstraint haveCourier12 [expr {[catch { + .t configure -font {Courier 12} +}] == 0}] pack append . .t {top expand fill} update .t debug on @@ -84,219 +82,219 @@ foreach test { {expected boolean value but got "stupid"}} } { set name [lindex $test 0] - test textTag-1.$i {tag configuration options} courier12 { + test textTag-1.$i {tag configuration options} haveCourier12 { .t tag configure x $name [lindex $test 1] .t tag cget x $name } [lindex $test 2] incr i if {[lindex $test 3] != ""} { - test textTag-1.$i {configuration options} courier12 { + test textTag-1.$i {configuration options} haveCourier12 { list [catch {.t tag configure x $name [lindex $test 3]} msg] $msg } [list 1 [lindex $test 4]] } .t tag configure x $name [lindex [.t tag configure x $name] 3] incr i } -test textTag-2.1 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.1 {TkTextTagCmd - "add" option} haveCourier12 { list [catch {.t tag} msg] $msg } {1 {wrong # args: should be ".t tag option ?arg arg ...?"}} -test textTag-2.2 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.2 {TkTextTagCmd - "add" option} haveCourier12 { list [catch {.t tag gorp} msg] $msg -} {1 {bad tag option "gorp": must be add, bind, cget, configure, delete, lower, names, nextrange, raise, ranges, or remove}} -test textTag-2.3 {TkTextTagCmd - "add" option} courier12 { +} {1 {bad tag option "gorp": must be add, bind, cget, configure, delete, lower, names, nextrange, prevrange, raise, ranges, or remove}} +test textTag-2.3 {TkTextTagCmd - "add" option} haveCourier12 { list [catch {.t tag add foo} msg] $msg } {1 {wrong # args: should be ".t tag add tagName index1 ?index2 index1 index2 ...?"}} -test textTag-2.4 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.4 {TkTextTagCmd - "add" option} haveCourier12 { list [catch {.t tag add x gorp} msg] $msg } {1 {bad text index "gorp"}} -test textTag-2.5 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.5 {TkTextTagCmd - "add" option} haveCourier12 { list [catch {.t tag add x 1.2 gorp} msg] $msg } {1 {bad text index "gorp"}} -test textTag-2.6 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.6 {TkTextTagCmd - "add" option} haveCourier12 { .t tag add sel 3.2 3.4 .t tag add sel 3.2 3.0 .t tag ranges sel } {3.2 3.4} -test textTag-2.7 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.7 {TkTextTagCmd - "add" option} haveCourier12 { .t tag add x 1.0 1.end .t tag ranges x } {1.0 1.6} -test textTag-2.8 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.8 {TkTextTagCmd - "add" option} haveCourier12 { .t tag remove x 1.0 end .t tag add x 1.2 .t tag ranges x } {1.2 1.3} -test textTag-2.9 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.9 {TkTextTagCmd - "add" option} haveCourier12 { .t.e select from 0 .t.e select to 4 .t tag add sel 3.2 3.4 selection get } 34 -test textTag-2.11 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.11 {TkTextTagCmd - "add" option} haveCourier12 { .t.e select from 0 .t.e select to 4 .t configure -exportselection 0 .t tag add sel 3.2 3.4 selection get } Text -test textTag-2.12 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.12 {TkTextTagCmd - "add" option} haveCourier12 { .t tag remove sel 1.0 end .t tag add sel 1.1 1.5 2.4 3.1 4.2 4.4 .t tag ranges sel } {1.1 1.5 2.4 3.1 4.2 4.4} -test textTag-2.13 {TkTextTagCmd - "add" option} courier12 { +test textTag-2.13 {TkTextTagCmd - "add" option} haveCourier12 { .t tag remove sel 1.0 end .t tag add sel 1.1 1.5 2.4 .t tag ranges sel } {1.1 1.5 2.4 2.5} catch {.t tag delete x} -test textTag-3.1 {TkTextTagCmd - "bind" option} courier12 { +test textTag-3.1 {TkTextTagCmd - "bind" option} haveCourier12 { list [catch {.t tag bind} msg] $msg } {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}} -test textTag-3.2 {TkTextTagCmd - "bind" option} courier12 { +test textTag-3.2 {TkTextTagCmd - "bind" option} haveCourier12 { list [catch {.t tag bind 1 2 3 4} msg] $msg } {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}} -test textTag-3.3 {TkTextTagCmd - "bind" option} courier12 { +test textTag-3.3 {TkTextTagCmd - "bind" option} haveCourier12 { .t tag bind x <Enter> script1 .t tag bind x <Enter> } script1 -test textTag-3.4 {TkTextTagCmd - "bind" option} courier12 { +test textTag-3.4 {TkTextTagCmd - "bind" option} haveCourier12 { list [catch {.t tag bind x <Gorp> script2} msg] $msg } {1 {bad event type or keysym "Gorp"}} -test textTag-3.5 {TkTextTagCmd - "bind" option} courier12 { +test textTag-3.5 {TkTextTagCmd - "bind" option} haveCourier12 { .t tag delete x .t tag bind x <Enter> script1 list [catch {.t tag bind x <FocusIn> script2} msg] $msg [.t tag bind x] } {1 {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used} <Enter>} -test textTag-3.6 {TkTextTagCmd - "bind" option} courier12 { +test textTag-3.6 {TkTextTagCmd - "bind" option} haveCourier12 { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <Leave> script2 .t tag bind x a xyzzy list [lsort [.t tag bind x]] [.t tag bind x <Enter>] [.t tag bind x a] } {{<Enter> <Leave> a} script1 xyzzy} -test textTag-3.7 {TkTextTagCmd - "bind" option} courier12 { +test textTag-3.7 {TkTextTagCmd - "bind" option} haveCourier12 { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <Enter> +script2 .t tag bind x <Enter> } {script1 script2} -test textTag-3.7 {TkTextTagCmd - "bind" option} courier12 { +test textTag-3.7a {TkTextTagCmd - "bind" option} haveCourier12 { .t tag delete x list [catch {.t tag bind x <Enter>} msg] $msg } {0 {}} -test textTag-3.8 {TkTextTagCmd - "bind" option} courier12 { +test textTag-3.8 {TkTextTagCmd - "bind" option} haveCourier12 { .t tag delete x list [catch {.t tag bind x <} msg] $msg } {1 {no event type or button # or keysym}} -test textTag-4.1 {TkTextTagCmd - "cget" option} courier12 { +test textTag-4.1 {TkTextTagCmd - "cget" option} haveCourier12 { list [catch {.t tag cget a} msg] $msg } {1 {wrong # args: should be ".t tag cget tagName option"}} -test textTag-4.2 {TkTextTagCmd - "cget" option} courier12 { +test textTag-4.2 {TkTextTagCmd - "cget" option} haveCourier12 { list [catch {.t tag cget a b c} msg] $msg } {1 {wrong # args: should be ".t tag cget tagName option"}} -test textTag-4.3 {TkTextTagCmd - "cget" option} courier12 { +test textTag-4.3 {TkTextTagCmd - "cget" option} haveCourier12 { .t tag delete foo list [catch {.t tag cget foo bar} msg] $msg } {1 {tag "foo" isn't defined in text widget}} -test textTag-4.4 {TkTextTagCmd - "cget" option} courier12 { +test textTag-4.4 {TkTextTagCmd - "cget" option} haveCourier12 { list [catch {.t tag cget sel bogus} msg] $msg } {1 {unknown option "bogus"}} -test textTag-4.5 {TkTextTagCmd - "cget" option} courier12 { +test textTag-4.5 {TkTextTagCmd - "cget" option} haveCourier12 { .t tag delete x .t tag configure x -background red list [catch {.t tag cget x -background} msg] $msg } {0 red} -test textTag-5.1 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.1 {TkTextTagCmd - "configure" option} haveCourier12 { list [catch {.t tag configure} msg] $msg } {1 {wrong # args: should be ".t tag configure tagName ?option? ?value? ?option value ...?"}} -test textTag-5.2 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.2 {TkTextTagCmd - "configure" option} haveCourier12 { list [catch {.t tag configure x -foo} msg] $msg } {1 {unknown option "-foo"}} -test textTag-5.3 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.3 {TkTextTagCmd - "configure" option} haveCourier12 { list [catch {.t tag configure x -background red -underline} msg] $msg } {1 {value for "-underline" missing}} -test textTag-5.4 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.4 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x .t tag configure x -underline yes .t tag configure x -underline } {-underline {} {} {} yes} -test textTag-5.5 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.5 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x .t tag configure x -overstrike on .t tag cget x -overstrike } {on} -test textTag-5.6 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.6 {TkTextTagCmd - "configure" option} haveCourier12 { list [catch {.t tag configure x -overstrike foo} msg] $msg } {1 {expected boolean value but got "foo"}} -test textTag-5.7 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.7 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -underline stupid} msg] $msg } {1 {expected boolean value but got "stupid"}} -test textTag-5.8 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.8 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x .t tag configure x -justify left .t tag configure x -justify } {-justify {} {} {} left} -test textTag-5.9 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.9 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -justify bogus} msg] $msg } {1 {bad justification "bogus": must be left, right, or center}} -test textTag-5.10 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.10 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -justify fill} msg] $msg } {1 {bad justification "fill": must be left, right, or center}} -test textTag-5.11 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.11 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x .t tag configure x -offset 2 .t tag configure x -offset } {-offset {} {} {} 2} -test textTag-5.12 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.12 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -offset 1.0q} msg] $msg } {1 {bad screen distance "1.0q"}} -test textTag-5.13 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.13 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x .t tag configure x -lmargin1 2 -lmargin2 4 -rmargin 5 list [.t tag configure x -lmargin1] [.t tag configure x -lmargin2] \ [.t tag configure x -rmargin] } {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}} -test textTag-5.14 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.14 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -lmargin1 2.0x} msg] $msg } {1 {bad screen distance "2.0x"}} -test textTag-5.15 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.15 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -lmargin2 gorp} msg] $msg } {1 {bad screen distance "gorp"}} -test textTag-5.16 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.16 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -rmargin 140.1.1} msg] $msg } {1 {bad screen distance "140.1.1"}} .t tag delete x -test textTag-5.17 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.17 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x .t tag configure x -spacing1 2 -spacing2 4 -spacing3 6 list [.t tag configure x -spacing1] [.t tag configure x -spacing2] \ [.t tag configure x -spacing3] } {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}} -test textTag-5.18 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.18 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -spacing1 2.0x} msg] $msg } {1 {bad screen distance "2.0x"}} -test textTag-5.19 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.19 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -spacing1 lousy} msg] $msg } {1 {bad screen distance "lousy"}} -test textTag-5.20 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.20 {TkTextTagCmd - "configure" option} haveCourier12 { .t tag delete x list [catch {.t tag configure x -spacing1 4.2.3} msg] $msg } {1 {bad screen distance "4.2.3"}} -test textTag-5.21 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.21 {TkTextTagCmd - "configure" option} haveCourier12 { .t configure -selectborderwidth 2 -selectforeground blue \ -selectbackground black .t tag configure sel -borderwidth 4 -foreground green -background yellow @@ -306,19 +304,19 @@ test textTag-5.21 {TkTextTagCmd - "configure" option} courier12 { } set x } {4 green yellow} -test textTag-5.22 {TkTextTagCmd - "configure" option} courier12 { +test textTag-5.22 {TkTextTagCmd - "configure" option} haveCourier12 { .t configure -selectborderwidth 20 .t tag configure sel -borderwidth {} .t cget -selectborderwidth } {} -test textTag-6.1 {TkTextTagCmd - "delete" option} courier12 { +test textTag-6.1 {TkTextTagCmd - "delete" option} haveCourier12 { list [catch {.t tag delete} msg] $msg -} {1 {wrong # args: should be ".t tag delete tagName tagName ..."}} -test textTag-6.2 {TkTextTagCmd - "delete" option} courier12 { +} {1 {wrong # args: should be ".t tag delete tagName ?tagName ...?"}} +test textTag-6.2 {TkTextTagCmd - "delete" option} haveCourier12 { list [catch {.t tag delete zork} msg] $msg } {0 {}} -test textTag-6.3 {TkTextTagCmd - "delete" option} courier12 { +test textTag-6.3 {TkTextTagCmd - "delete" option} haveCourier12 { .t tag delete x .t tag config x -background black .t tag config y -foreground white @@ -326,14 +324,14 @@ test textTag-6.3 {TkTextTagCmd - "delete" option} courier12 { .t tag delete y z lsort [.t tag names] } {sel x} -test textTag-6.4 {TkTextTagCmd - "delete" option} courier12 { +test textTag-6.4 {TkTextTagCmd - "delete" option} haveCourier12 { .t tag config x -background black .t tag config y -foreground white .t tag config z -background black eval .t tag delete [.t tag names] .t tag names } {sel} -test textTag-6.5 {TkTextTagCmd - "delete" option} courier12 { +test textTag-6.5 {TkTextTagCmd - "delete" option} haveCourier12 { .t tag bind x <Enter> foo .t tag delete x .t tag configure x -background black @@ -347,39 +345,39 @@ proc tagsetup {} { .t tag configure $i -background black } } -test textTag-7.1 {TkTextTagCmd - "lower" option} courier12 { +test textTag-7.1 {TkTextTagCmd - "lower" option} haveCourier12 { list [catch {.t tag lower} msg] $msg } {1 {wrong # args: should be ".t tag lower tagName ?belowThis?"}} -test textTag-7.2 {TkTextTagCmd - "lower" option} courier12 { +test textTag-7.2 {TkTextTagCmd - "lower" option} haveCourier12 { list [catch {.t tag lower foo} msg] $msg } {1 {tag "foo" isn't defined in text widget}} -test textTag-7.3 {TkTextTagCmd - "lower" option} courier12 { +test textTag-7.3 {TkTextTagCmd - "lower" option} haveCourier12 { list [catch {.t tag lower sel bar} msg] $msg } {1 {tag "bar" isn't defined in text widget}} -test textTag-7.4 {TkTextTagCmd - "lower" option} courier12 { +test textTag-7.4 {TkTextTagCmd - "lower" option} haveCourier12 { tagsetup .t tag lower c .t tag names } {c sel a b d} -test textTag-7.5 {TkTextTagCmd - "lower" option} courier12 { +test textTag-7.5 {TkTextTagCmd - "lower" option} haveCourier12 { tagsetup .t tag lower d b .t tag names } {sel a d b c} -test textTag-7.6 {TkTextTagCmd - "lower" option} courier12 { +test textTag-7.6 {TkTextTagCmd - "lower" option} haveCourier12 { tagsetup .t tag lower a c .t tag names } {sel b a c d} -test textTag-8.1 {TkTextTagCmd - "names" option} courier12 { +test textTag-8.1 {TkTextTagCmd - "names" option} haveCourier12 { list [catch {.t tag names a b} msg] $msg } {1 {wrong # args: should be ".t tag names ?index?"}} -test textTag-8.2 {TkTextTagCmd - "names" option} courier12 { +test textTag-8.2 {TkTextTagCmd - "names" option} haveCourier12 { tagsetup .t tag names } {sel a b c d} -test textTag-8.3 {TkTextTagCmd - "names" option} courier12 { +test textTag-8.3 {TkTextTagCmd - "names" option} haveCourier12 { tagsetup .t tag add "a b" 2.1 2.6 .t tag add c 2.4 2.7 @@ -390,148 +388,148 @@ test textTag-8.3 {TkTextTagCmd - "names" option} courier12 { .t tag add x 2.3 2.5 .t tag add x 2.9 3.1 .t tag add x 7.2 -test textTag-9.1 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.1 {TkTextTagCmd - "nextrange" option} haveCourier12 { list [catch {.t tag nextrange x} msg] $msg } {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}} -test textTag-9.2 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.2 {TkTextTagCmd - "nextrange" option} haveCourier12 { list [catch {.t tag nextrange x 1 2 3} msg] $msg } {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}} -test textTag-9.3 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.3 {TkTextTagCmd - "nextrange" option} haveCourier12 { list [catch {.t tag nextrange foo 1.0} msg] $msg } {0 {}} -test textTag-9.4 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.4 {TkTextTagCmd - "nextrange" option} haveCourier12 { list [catch {.t tag nextrange x foo} msg] $msg } {1 {bad text index "foo"}} -test textTag-9.5 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.5 {TkTextTagCmd - "nextrange" option} haveCourier12 { list [catch {.t tag nextrange x 1.0 bar} msg] $msg } {1 {bad text index "bar"}} -test textTag-9.6 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.6 {TkTextTagCmd - "nextrange" option} haveCourier12 { .t tag nextrange x 1.0 } {2.3 2.5} -test textTag-9.7 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.7 {TkTextTagCmd - "nextrange" option} haveCourier12 { .t tag nextrange x 2.2 } {2.3 2.5} -test textTag-9.8 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.8 {TkTextTagCmd - "nextrange" option} haveCourier12 { .t tag nextrange x 2.3 } {2.3 2.5} -test textTag-9.9 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.9 {TkTextTagCmd - "nextrange" option} haveCourier12 { .t tag nextrange x 2.4 } {2.9 3.1} -test textTag-9.10 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.10 {TkTextTagCmd - "nextrange" option} haveCourier12 { .t tag nextrange x 2.4 2.9 } {} -test textTag-9.11 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.11 {TkTextTagCmd - "nextrange" option} haveCourier12 { .t tag nextrange x 2.4 2.10 } {2.9 3.1} -test textTag-9.12 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.12 {TkTextTagCmd - "nextrange" option} haveCourier12 { .t tag nextrange x 2.4 2.11 } {2.9 3.1} -test textTag-9.13 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.13 {TkTextTagCmd - "nextrange" option} haveCourier12 { .t tag nextrange x 7.0 } {7.2 7.3} -test textTag-9.14 {TkTextTagCmd - "nextrange" option} courier12 { +test textTag-9.14 {TkTextTagCmd - "nextrange" option} haveCourier12 { .t tag nextrange x 7.3 } {} -test textTag-10.1 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.1 {TkTextTagCmd - "prevrange" option} haveCourier12 { list [catch {.t tag prevrange x} msg] $msg } {1 {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}} -test textTag-10.2 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.2 {TkTextTagCmd - "prevrange" option} haveCourier12 { list [catch {.t tag prevrange x 1 2 3} msg] $msg } {1 {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}} -test textTag-10.3 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.3 {TkTextTagCmd - "prevrange" option} haveCourier12 { list [catch {.t tag prevrange foo end} msg] $msg } {0 {}} -test textTag-10.4 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.4 {TkTextTagCmd - "prevrange" option} haveCourier12 { list [catch {.t tag prevrange x foo} msg] $msg } {1 {bad text index "foo"}} -test textTag-10.5 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.5 {TkTextTagCmd - "prevrange" option} haveCourier12 { list [catch {.t tag prevrange x end bar} msg] $msg } {1 {bad text index "bar"}} -test textTag-10.6 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.6 {TkTextTagCmd - "prevrange" option} haveCourier12 { .t tag prevrange x end } {7.2 7.3} -test textTag-10.7 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.7 {TkTextTagCmd - "prevrange" option} haveCourier12 { .t tag prevrange x 2.4 } {2.3 2.5} -test textTag-10.8 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.8 {TkTextTagCmd - "prevrange" option} haveCourier12 { .t tag prevrange x 2.5 } {2.3 2.5} -test textTag-10.9 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.9 {TkTextTagCmd - "prevrange" option} haveCourier12 { .t tag prevrange x 2.9 } {2.3 2.5} -test textTag-10.10 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.10 {TkTextTagCmd - "prevrange" option} haveCourier12 { .t tag prevrange x 2.9 2.6 } {} -test textTag-10.11 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.11 {TkTextTagCmd - "prevrange" option} haveCourier12 { .t tag prevrange x 2.9 2.5 } {} -test textTag-10.12 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.12 {TkTextTagCmd - "prevrange" option} haveCourier12 { .t tag prevrange x 2.9 2.3 } {2.3 2.5} -test textTag-10.13 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.13 {TkTextTagCmd - "prevrange" option} haveCourier12 { .t tag prevrange x 7.0 } {2.9 3.1} -test textTag-10.14 {TkTextTagCmd - "prevrange" option} courier12 { +test textTag-10.14 {TkTextTagCmd - "prevrange" option} haveCourier12 { .t tag prevrange x 2.3 } {} -test textTag-11.1 {TkTextTagCmd - "raise" option} courier12 { +test textTag-11.1 {TkTextTagCmd - "raise" option} haveCourier12 { list [catch {.t tag raise} msg] $msg } {1 {wrong # args: should be ".t tag raise tagName ?aboveThis?"}} -test textTag-11.2 {TkTextTagCmd - "raise" option} courier12 { +test textTag-11.2 {TkTextTagCmd - "raise" option} haveCourier12 { list [catch {.t tag raise foo} msg] $msg } {1 {tag "foo" isn't defined in text widget}} -test textTag-11.3 {TkTextTagCmd - "raise" option} courier12 { +test textTag-11.3 {TkTextTagCmd - "raise" option} haveCourier12 { list [catch {.t tag raise sel bar} msg] $msg } {1 {tag "bar" isn't defined in text widget}} -test textTag-11.4 {TkTextTagCmd - "raise" option} courier12 { +test textTag-11.4 {TkTextTagCmd - "raise" option} haveCourier12 { tagsetup .t tag raise c .t tag names } {sel a b d c} -test textTag-11.5 {TkTextTagCmd - "raise" option} courier12 { +test textTag-11.5 {TkTextTagCmd - "raise" option} haveCourier12 { tagsetup .t tag raise d b .t tag names } {sel a b d c} -test textTag-11.6 {TkTextTagCmd - "raise" option} courier12 { +test textTag-11.6 {TkTextTagCmd - "raise" option} haveCourier12 { tagsetup .t tag raise a c .t tag names } {sel b c a d} -test textTag-12.1 {TkTextTagCmd - "ranges" option} courier12 { +test textTag-12.1 {TkTextTagCmd - "ranges" option} haveCourier12 { list [catch {.t tag ranges} msg] $msg } {1 {wrong # args: should be ".t tag ranges tagName"}} -test textTag-12.2 {TkTextTagCmd - "ranges" option} courier12 { +test textTag-12.2 {TkTextTagCmd - "ranges" option} haveCourier12 { .t tag delete x .t tag ranges x } {} -test textTag-12.3 {TkTextTagCmd - "ranges" option} courier12 { +test textTag-12.3 {TkTextTagCmd - "ranges" option} haveCourier12 { .t tag delete x .t tag add x 2.2 .t tag add x 2.7 4.15 .t tag add x 5.2 5.5 .t tag ranges x } {2.2 2.3 2.7 4.6 5.2 5.5} -test textTag-12.4 {TkTextTagCmd - "ranges" option} courier12 { +test textTag-12.4 {TkTextTagCmd - "ranges" option} haveCourier12 { .t tag delete x .t tag add x 1.0 3.0 .t tag add x 4.0 end .t tag ranges x } {1.0 3.0 4.0 8.0} -test textTag-13.1 {TkTextTagCmd - "remove" option} courier12 { +test textTag-13.1 {TkTextTagCmd - "remove" option} haveCourier12 { list [catch {.t tag remove} msg] $msg } {1 {wrong # args: should be ".t tag remove tagName index1 ?index2 index1 index2 ...?"}} -test textTag-13.2 {TkTextTagCmd - "remove" option} courier12 { +test textTag-13.2 {TkTextTagCmd - "remove" option} haveCourier12 { .t tag delete x .t tag add x 2.2 2.11 .t tag remove x 2.3 2.7 .t tag ranges x } {2.2 2.3 2.7 2.11} -test textTag-13.3 {TkTextTagCmd - "remove" option} courier12 { +test textTag-13.3 {TkTextTagCmd - "remove" option} haveCourier12 { .t configure -exportselection 1 .t tag remove sel 1.0 end .t tag add sel 2.4 3.3 @@ -541,14 +539,14 @@ test textTag-13.3 {TkTextTagCmd - "remove" option} courier12 { } Text .t tag delete x a b c d -test textTag-14.1 {SortTags} courier12 { +test textTag-14.1 {SortTags} haveCourier12 { foreach i {a b c d} { .t tag add $i 2.0 2.2 } .t tag names 2.1 } {a b c d} .t tag delete a b c d -test textTag-14.2 {SortTags} courier12 { +test textTag-14.2 {SortTags} haveCourier12 { foreach i {a b c d} { .t tag configure $i -background black } @@ -558,13 +556,13 @@ test textTag-14.2 {SortTags} courier12 { .t tag names 2.1 } {a b c d} .t tag delete x a b c d -test textTag-14.3 {SortTags} courier12 { +test textTag-14.3 {SortTags} haveCourier12 { for {set i 0} {$i < 30} {incr i} { .t tag add x$i 2.0 2.2 } .t tag names 2.1 } {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} -test textTag-14.4 {SortTags} courier12 { +test textTag-14.4 {SortTags} haveCourier12 { for {set i 0} {$i < 30} {incr i} { .t tag configure x$i -background black } @@ -587,7 +585,7 @@ set c [.t bbox 4.3] set x3 [expr [lindex $c 0] + [lindex $c 2]/2] set y3 [expr [lindex $c 1] + [lindex $c 3]/2] -test textTag-15.1 {TkTextBindProc} courier12 { +test textTag-15.1 {TkTextBindProc} haveCourier12 { bind .t <ButtonRelease> {lappend x up} .t tag bind x <ButtonRelease> {lappend x x-up} .t tag bind y <ButtonRelease> {lappend x y-up} @@ -606,7 +604,7 @@ test textTag-15.1 {TkTextBindProc} courier12 { bind .t <ButtonRelease> {} set x } {x-up up up y-up up} -test textTag-15.2 {TkTextBindProc} courier12 { +test textTag-15.2 {TkTextBindProc} haveCourier12 { catch {.t tag delete x} catch {.t tag delete y} .t tag bind x <Enter> {lappend x x-enter} @@ -630,7 +628,7 @@ test textTag-15.2 {TkTextBindProc} courier12 { event gen .t <ButtonRelease> -x $x3 -y $y3 set x } {x-enter | x-down | | x-up x-leave y-enter} -test textTag-15.3 {TkTextBindProc} courier12 { +test textTag-15.3 {TkTextBindProc} haveCourier12 { catch {.t tag delete x} catch {.t tag delete y} .t tag bind x <Enter> {lappend x x-enter} @@ -663,7 +661,7 @@ foreach tag [.t tag names] { catch {.t tag delete $tag} } .t tag configure big -font $bigFont -test textTag-16.1 {TkTextPickCurrent procedure} courier12 { +test textTag-16.1 {TkTextPickCurrent procedure} haveCourier12 { event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1 set x [.t index current] event gen .t <Motion> -x $x2 -y $y2 @@ -679,7 +677,7 @@ test textTag-16.1 {TkTextPickCurrent procedure} courier12 { event gen .t <ButtonRelease-1> -state 0x100 -x $x3 -y $y3 lappend x [.t index current] } {2.1 3.2 3.2 3.2 3.2 3.2 4.3} -test textTag-16.2 {TkTextPickCurrent procedure} courier12 { +test textTag-16.2 {TkTextPickCurrent procedure} haveCourier12 { event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1 event gen .t <Motion> -x $x2 -y $y2 set x [.t index current] @@ -692,7 +690,7 @@ foreach i {a b c d} { .t tag bind $i <Enter> "lappend x enter-$i" .t tag bind $i <Leave> "lappend x leave-$i" } -test textTag-16.3 {TkTextPickCurrent procedure} courier12 { +test textTag-16.3 {TkTextPickCurrent procedure} haveCourier12 { foreach i {a b c d} { .t tag remove $i 1.0 end } @@ -710,7 +708,7 @@ test textTag-16.3 {TkTextPickCurrent procedure} courier12 { event gen .t <Motion> -x $x3 -y $y3 set x } {enter-a enter-b | leave-b enter-c | leave-a leave-c} -test textTag-16.4 {TkTextPickCurrent procedure} courier12 { +test textTag-16.4 {TkTextPickCurrent procedure} haveCourier12 { foreach i {a b c d} { .t tag remove $i 1.0 end } @@ -730,7 +728,7 @@ test textTag-16.4 {TkTextPickCurrent procedure} courier12 { foreach i {a b c d} { .t tag delete $i } -test textTag-16.5 {TkTextPickCurrent procedure} courier12 { +test textTag-16.5 {TkTextPickCurrent procedure} haveCourier12 { foreach i {a b c d} { .t tag remove $i 1.0 end } @@ -740,7 +738,7 @@ test textTag-16.5 {TkTextPickCurrent procedure} courier12 { event gen .t <Motion> -x $x2 -y $y2 .t index current } {3.2} -test textTag-16.6 {TkTextPickCurrent procedure} courier12 { +test textTag-16.6 {TkTextPickCurrent procedure} haveCourier12 { foreach i {a b c d} { .t tag remove $i 1.0 end } @@ -751,7 +749,7 @@ test textTag-16.6 {TkTextPickCurrent procedure} courier12 { update .t index current } {3.1} -test textTag-16.7 {TkTextPickCurrent procedure} courier12 { +test textTag-16.7 {TkTextPickCurrent procedure} haveCourier12 { foreach i {a b c d} { .t tag remove $i 1.0 end } @@ -762,21 +760,43 @@ test textTag-16.7 {TkTextPickCurrent procedure} courier12 { .t index current } {3.1} -catch {destroy .t} - -# cleanup -::tcltest::cleanupTests -return - - - - - - - - - +test textTag-17.1 {insert procedure inserts tags} { + .t delete 1.0 end + # Objectification of the text widget had a problem + # with inserting tags when using 'end'. Check that + # bug has been fixed. + .t insert end abcd {x} \n {} efgh {y} \n {} + .t dump -tag 1.0 end +} {tagon x 1.0 tagoff x 1.4 tagon y 2.0 tagoff y 2.4} +catch {destroy .t} +test textTag-18.1 {TkTextPickCurrent tag bindings} { + text .t -width 30 -height 4 -relief sunken -borderwidth 10 \ + -highlightthickness 10 -pady 2 + pack .t + + .t insert end " Tag here " TAG " no tag here" + .t tag configure TAG -borderwidth 4 -relief raised + .t tag bind TAG <Enter> {lappend res "%x %y tag-Enter"} + .t tag bind TAG <Leave> {lappend res "%x %y tag-Leave"} + bind .t <Enter> {lappend res Enter} + bind .t <Leave> {lappend res Leave} + + set res {} + # Bindings must not trigger on the widget border, only over + # the actual tagged characters themselves. + event gen .t <Motion> -warp 1 -x 0 -y 0 ; update + event gen .t <Motion> -warp 1 -x 10 -y 10 ; update + event gen .t <Motion> -warp 1 -x 25 -y 25 ; update + event gen .t <Motion> -warp 1 -x 20 -y 20 ; update + event gen .t <Motion> -warp 1 -x 10 -y 10 ; update + event gen .t <Motion> -warp 1 -x 25 -y 25 ; update + set res +} {Enter {25 25 tag-Enter} {20 20 tag-Leave} {25 25 tag-Enter}} +catch {destroy .t} +# cleanup +cleanupTests +return diff --git a/tests/textWind.test b/tests/textWind.test index 66e239d..79dca50 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # Create entries in the option database to be sure that geometry options @@ -20,17 +17,26 @@ option add *Text.borderWidth 2 option add *Text.highlightThickness 2 option add *Text.font {Courier -12} +set fixedFont {Courier -12} +# 15 on XP, 13 on Solaris 8 +set fixedHeight [font metrics $fixedFont -linespace] +# 7 on all platforms +set fixedWidth [font measure $fixedFont m] +# 12 on XP +set fixedAscent [font metrics $fixedFont -ascent] +set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP + +catch {destroy .f} +catch {destroy .t} +catch {destroy .t2} + text .t -width 30 -height 6 -bd 2 -highlightthickness 2 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. @@ -182,13 +188,14 @@ test textWind-2.18 {TkTextWindowCmd procedure} { } {1 {unknown option "-gorp"} 0 1.0 1} test textWind-2.19 {TkTextWindowCmd procedure} { .t delete 1.0 end + catch {destroy .f} frame .f -width 10 -height 6 -bg $color list [catch {.t window create 1.0 -gorp -window .f stupid} msg] $msg \ [winfo exists .f] [.t index 1.end] [catch {.t index .f}] } {1 {unknown option "-gorp"} 1 1.0 1} test textWind-2.20 {TkTextWindowCmd procedure} { list [catch {.t window c} msg] $msg -} {1 {bad window option "c": must be cget, configure, create, or names}} +} {1 {ambiguous window option "c": must be cget, configure, create, or names}} destroy .f test textWind-2.21 {TkTextWindowCmd procedure, "names" option} { list [catch {.t window names foo} msg] $msg @@ -305,7 +312,7 @@ test textWind-4.5 {AlignParseProc and AlignPrintProc procedures} { .t window configure 1.0 -align top list [catch {.t window configure 1.0 -align gorp} msg] $msg \ [.t window configure 1.0 -align] -} {1 {bad alignment "gorp": must be baseline, bottom, center, or top} {-align {} {} center top}} +} {1 {bad align "gorp": must be baseline, bottom, center, or top} {-align {} {} center top}} test textWind-5.1 {EmbWinStructureProc procedure} {fonts} { .t delete 1.0 end @@ -348,7 +355,7 @@ test textWind-6.1 {EmbWinRequestProc procedure} {fonts} { lappend result [.t bbox 1.2] [.t bbox 1.3] } {{19 5 10 20} {29 8 7 13} {19 5 25 30} {44 13 7 13}} -test textWind-7.1 {EmbWinLostSlaveProc procedure} {fonts} { +test textWind-7.1 {EmbWinLostSlaveProc procedure} {textfonts} { .t delete 1.0 end .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color @@ -357,8 +364,8 @@ test textWind-7.1 {EmbWinLostSlaveProc procedure} {fonts} { place .f -in .t -x 100 -y 50 update list [winfo geom .f] [.t bbox 1.2] -} {10x20+104+54 {19 11 0 0}} -test textWind-7.2 {EmbWinLostSlaveProc procedure} {fonts} { +} [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] +test textWind-7.2 {EmbWinLostSlaveProc procedure} {textfonts} { .t delete 1.0 end .t insert 1.0 "Some sample text" frame .t.f -width 10 -height 20 -bg $color @@ -367,7 +374,7 @@ test textWind-7.2 {EmbWinLostSlaveProc procedure} {fonts} { place .t.f -x 100 -y 50 update list [winfo geom .t.f] [.t bbox 1.2] -} {10x20+104+54 {19 11 0 0}} +} [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] catch {destroy .f} catch {destroy .t.f} @@ -400,12 +407,13 @@ proc bgerror args { test textWind-10.1 {EmbWinLayoutProc procedure} { .t delete 1.0 end .t insert 1.0 "Some sample text" + destroy .f .t window create 1.5 -create { frame .f -width 10 -height 20 -bg $color } update - list [winfo exists .f] [winfo geom .f] [.t index .f] -} {1 10x20+40+5 1.5} + list [winfo exists .f] [winfo width .f] [winfo height .f] [.t index .f] +} {1 10 20 1.5} test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} {fonts} { .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -426,40 +434,85 @@ test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} {fonts update list $msg [.t bbox 1.5] } {{{bad window path name "gorp"}} {40 11 0 0}} -test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} {fonts} { +proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } +} +test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { .t delete 1.0 end .t insert 1.0 "Some sample text" + catch {destroy .t.f} + set msg {} + after idle { + .t window create 1.5 -create { + frame .t.f + frame .t.f.f -width 10 -height 20 -bg $color + } + } + set count 0 + while {([llength $msg] < 2) && ($count < 100)} { + update ; incr count; .t bbox 1.5 ; after 10 + } + lappend msg [.t bbox 1.5] [winfo exists .t.f.f] +} [list {{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0] 1] +test textWind-10.4.1 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + catch {destroy .t.f} .t window create 1.5 -create { frame .t.f frame .t.f.f -width 10 -height 20 -bg $color } - set msg xyzzy - update - list $msg [.t bbox 1.5] [winfo exists .t.f.f] -} {{{can't embed .t.f.f relative to .t}} {40 11 0 0} 1} + set msg {} + update idletasks + lappend msg [winfo exists .t.f.f] +} [list {{can't embed .t.f.f relative to .t}} 1] catch {destroy .t.f} -test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} {fonts} { +test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { .t delete 1.0 end .t insert 1.0 "Some sample text" .t window create 1.5 -create { concat .t } - set msg xyzzy + set msg {} update - list $msg [.t bbox 1.5] -} {{{can't embed .t relative to .t}} {40 11 0 0}} -test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} {fonts} { + lappend msg [.t bbox 1.5] +} [list {{can't embed .t relative to .t}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] +test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { .t delete 1.0 end .t insert 1.0 "Some sample text" + catch {destroy .t2} .t window create 1.5 -create { toplevel .t2 -width 100 -height 150 wm geom .t2 +0+0 concat .t2 } - set msg xyzzy + set msg {} update - list $msg [.t bbox 1.5] -} {{{can't embed .t2 relative to .t}} {40 11 0 0}} + lappend msg [.t bbox 1.5] +} [list {{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] +test textWind-10.6.1 {EmbWinLayoutProc procedure, error in creating window} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + catch {destroy .t2} + .t window create 1.5 -create { + toplevel .t2 -width 100 -height 150 + wm geom .t2 +0+0 + concat .t2 + } + set msg {} + update + set i 0 + while {[llength $msg] == 1 && [incr i] < 200} { update } + set msg +} {{{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}}} + +proc bgerror args { + global msg + set msg $args +} test textWind-10.7 {EmbWinLayoutProc procedure, steal window from self} { .t delete 1.0 end .t insert 1.0 ABCDEFGHIJKLMNOP @@ -627,7 +680,7 @@ test textWind-13.1 {EmbWinBboxProc procedure} { update list [winfo geom .f] [.t bbox .f] } {5x5+21+6 {21 6 5 5}} -test textWind-13.2 {EmbWinBboxProc procedure} { +test textWind-13.2 {EmbWinBboxProc procedure} {fonts} { .t delete 1.0 end .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color @@ -683,7 +736,7 @@ test textWind-13.8 {EmbWinBboxProc procedure} {fonts} { update list [winfo geom .f] [.t bbox .f] } {5x11+21+6 {21 6 5 11}} -test textWind-13.9 {EmbWinBboxProc procedure, spacing options} { +test textWind-13.9 {EmbWinBboxProc procedure, spacing options} {fonts} { .t configure -spacing1 5 -spacing3 2 .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -733,7 +786,7 @@ test textWind-14.3 {EmbWinDelayedUnmap procedure} { update .t yview 2.0 set result [winfo ismapped .f] - update + update ; after 10 list $result [winfo ismapped .f] } {1 0} test textWind-14.4 {EmbWinDelayedUnmap procedure} { @@ -814,22 +867,165 @@ test textWind-16.4 {EmbWinTextStructureProc procedure} { } {1 {47 5 30 20}} pack .t -catch {destroy .t} -option clear - -# cleanup -::tcltest::cleanupTests -return - - +test textWind-17.1 {peer widgets and embedded windows} { + catch {destroy .t .tt} + pack [text .t] + .t delete 1.0 end + .t insert end "Line 1" + frame .f -width 20 -height 10 -bg blue + .t window create 1.3 -window .f + toplevel .tt + pack [.t peer create .tt.t] + update ; update + destroy .t .tt + winfo exists .f +} {0} +test textWind-17.2 {peer widgets and embedded windows} { + catch {destroy .t .f} + pack [text .t] + .t delete 1.0 end + .t insert end "Line 1\nLine 2" + frame .f -width 20 -height 10 -bg blue + .t window create 1.4 -window .f + toplevel .tt + pack [.t peer create .tt.t] + update ; update + destroy .t + .tt.t insert 1.0 "foo" + update + destroy .tt +} {} +test textWind-17.3 {peer widget and -create} { + catch {destroy .t} + pack [text .t] + .t delete 1.0 end + .t insert 1.0 "Some sample text" + toplevel .tt + pack [.t peer create .tt.t] + update ; update + .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} + update + destroy .t .tt +} {} +test textWind-17.4 {peer widget deleted one window shouldn't delete others} { + catch {destroy .t .tt} + pack [text .t] + .t delete 1.0 end + .t insert 1.0 "Some sample text" + toplevel .tt + pack [.t peer create .tt.t] + .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} + update ; update + destroy .tt + set res {} + lappend res [.t get 1.2] + update + lappend res [.t get 1.2] +} {{} {}} +test textWind-17.5 {peer widget window configuration} { + catch {destroy .t .tt} + pack [text .t] + .t delete 1.0 end + .t insert 1.0 "Some sample text" + toplevel .tt + pack [.t peer create .tt.t] + .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} + update ; update + set res [list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]] + destroy .tt .t + set res +} {.t.f .tt.t.f} +test textWind-17.6 {peer widget window configuration} { + catch {destroy .t .tt} + pack [text .t] + .t delete 1.0 end + .t insert 1.0 "Some sample text" + toplevel .tt + pack [.t peer create .tt.t] + .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} + update ; update + set res [list [.t window configure 1.2 -window] \ + [.tt.t window configure 1.2 -window]] + destroy .tt .t + set res +} {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +test textWind-17.7 {peer widget window configuration} { + catch {destroy .t .tt} + pack [text .t] + .t delete 1.0 end + .t insert 1.0 "Some sample text" + toplevel .tt + pack [.t peer create .tt.t] + .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] + update ; update + set res [list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]] + destroy .tt .t + set res +} {.t.f {}} +test textWind-17.8 {peer widget window configuration} { + catch {destroy .t .tt} + pack [text .t] + .t delete 1.0 end + .t insert 1.0 "Some sample text" + toplevel .tt + pack [.t peer create .tt.t] + .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] + update ; update + set res [list [.t window configure 1.2 -window] \ + [.tt.t window configure 1.2 -window]] + destroy .tt .t + set res +} {{-window {} {} {} .t.f} {-window {} {} {} {}}} +test textWind-17.8a {peer widget window configuration} { + catch {destroy .t .tt} + pack [text .t] + .t delete 1.0 end + .t insert 1.0 "Some sample text" + toplevel .tt + pack [.t peer create .tt.t] + .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] + update ; update + .tt.t window configure 1.2 -window [frame .tt.t.f -width 10 -height 20 -bg red] + set res [list [.t window configure 1.2 -window] \ + [.tt.t window configure 1.2 -window]] + destroy .tt .t + set res +} {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +test textWind-17.9 {peer widget window configuration} { + catch {destroy .t .tt} + pack [text .t] + .t delete 1.0 end + .t insert 1.0 "Some sample text" + toplevel .tt + pack [.t peer create .tt.t] + .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] + .tt.t window create 1.2 -window [frame .tt.t.f -width 25 -height 20 -bg blue] + update ; update + .t window configure 1.2 -create \ + {destroy %W.f ; frame %W.f -width 50 -height 7 -bg red} + .tt.t window configure 1.2 -window {} + .t window configure 1.2 -window {} + set res [list [.t window configure 1.2 -window] \ + [.tt.t window configure 1.2 -window]] + update + lappend res [.t window configure 1.2 -window] \ + [.tt.t window configure 1.2 -window] + destroy .tt .t + set res +} {{-window {} {} {} {}} {-window {} {} {} {}} {-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +catch {destroy .t} +option clear +# cleanup +cleanupTests +return diff --git a/tests/tk.test b/tests/tk.test index 261b97e..02b4257 100644 --- a/tests/tk.test +++ b/tests/tk.test @@ -6,18 +6,15 @@ # Copyright (c) 2002 ActiveState Corporation. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -test tk-1.1 {tk command: general} { - list [catch {tk} msg] $msg -} {1 {wrong # args: should be "tk option ?arg?"}} -test tk-1.2 {tk command: general} { - list [catch {tk xyz} msg] $msg -} {1 {bad option "xyz": must be appname, caret, scaling, useinputmethods, or windowingsystem}} +test tk-1.1 {tk command: general} \ + -body {tk} -returnCodes 1 \ + -result {wrong # args: should be "tk option ?arg?"} +test tk-1.2 {tk command: general} \ + -body {tk xyz} -returnCodes 1 \ + -result {bad option "xyz": must be appname, caret, scaling, useinputmethods, windowingsystem, or inactive} set appname [tk appname] test tk-2.1 {tk command: appname} { @@ -26,7 +23,7 @@ test tk-2.1 {tk command: appname} { test tk-2.2 {tk command: appname} { tk appname foobazgarply } {foobazgarply} -test tk-2.3 {tk command: appname} {unixOnly} { +test tk-2.3 {tk command: appname} unix { tk appname bazfoogarply expr {[lsearch -exact [winfo interps] [tk appname]] >= 0} } {1} @@ -95,7 +92,7 @@ test tk-4.4 {tk command: useinputmethods: set new} { test tk-4.5 {tk command: useinputmethods: set new} { list [catch {tk useinputmethods -displayof . xyz} msg] $msg } {1 {expected boolean value but got "xyz"}} -test tk-4.6 {tk command: useinputmethods: set new} {unixOnly} { +test tk-4.6 {tk command: useinputmethods: set new} unix { # This isn't really a test, but more of a check... # The answer is what was given, because we may be on a Unix # system that doesn't have the XIM stuff @@ -104,7 +101,7 @@ test tk-4.6 {tk command: useinputmethods: set new} {unixOnly} { } set useim } $useim -test tk-4.7 {tk command: useinputmethods: set new} {macOrPc} { +test tk-4.7 {tk command: useinputmethods: set new} win { # Mac and Windows don't have X Input Methods, so this should # always return 0 tk useinputmethods 1 @@ -130,6 +127,38 @@ test tk-5.6 {tk caret} { list [catch {tk caret . -x 20 -y 25 -h 30; tk caret . -hei} msg] $msg } {0 30} +# tk inactive +test tk-6.1 {tk inactive} -body { + string is integer [tk inactive] +} -result 1 +test tk-6.2 {tk inactive reset} -body { + catch {tk inactive reset} +} -result 0 +test tk-6.3 {tk inactive wrong argument} -body { + tk inactive foo +} -returnCodes 1 -result {bad option "foo": must be reset} +test tk-6.4 {tk inactive too many arguments} -body { + tk inactive reset foo +} -returnCodes 1 -result {wrong # args: should be "tk inactive ?-displayof window? ?reset?"} +test tk-6.5 {tk inactive} -body { + tk inactive reset + update + after 100 + set i [tk inactive] + expr {$i == -1 || ( $i > 90 && $i < 200 )} +} -result 1 + +# tk inactive in safe interpreters +safe::interpCreate foo +safe::loadTk foo +test tk-7.1 {tk inactive in a safe interpreter} -body { + foo eval {tk inactive} +} -result -1 +test tk-7.2 {tk inactive reset in a safe interpreter} -body { + foo eval {tk inactive reset} +} -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter} +::safe::interpDelete foo + # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/ttk/all.tcl b/tests/ttk/all.tcl new file mode 100644 index 0000000..da2e316 --- /dev/null +++ b/tests/ttk/all.tcl @@ -0,0 +1,21 @@ +# all.tcl -- +# +# This file contains a top-level script to run all of the ttk +# tests. Execute it by invoking "source all.tcl" when running tktest +# in this directory. +# +# Copyright (c) 2007 by the Tk developers. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5 +package require tcltest 2.2 +package require Tk ;# This is the Tk test suite; fail early if no Tk! +tcltest::configure {*}$argv +tcltest::configure -testdir [file normalize [file dirname [info script]]] +tcltest::configure -loadfile \ + [file join [file dirname [tcltest::testsDirectory]] constraints.tcl] +tcltest::configure -singleproc 1 +tcltest::runAllTests + diff --git a/tests/ttk/checkbutton.test b/tests/ttk/checkbutton.test new file mode 100644 index 0000000..e18ff32 --- /dev/null +++ b/tests/ttk/checkbutton.test @@ -0,0 +1,48 @@ +# +# ttk::checkbutton widget tests. +# + +package require Tk +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +test checkbutton-1.1 "Checkbutton check" -body { + pack [ttk::checkbutton .cb -text "TCheckbutton" -variable cb] +} +test checkbutton-1.2 "Checkbutton invoke" -body { + .cb invoke + list [set ::cb] [.cb instate selected] +} -result [list 1 1] +test checkbutton-1.3 "Checkbutton reinvoke" -body { + .cb invoke + list [set ::cb] [.cb instate selected] +} -result [list 0 0] + +test checkbutton-1.4 "Checkbutton variable" -body { + set result [] + set ::cb 1 + lappend result [.cb instate selected] + set ::cb 0 + lappend result [.cb instate selected] +} -result {1 0} + +test checkbutton-1.5 "Unset checkbutton variable" -body { + set result [] + unset ::cb + lappend result [.cb instate alternate] [info exists ::cb] + set ::cb 1 + lappend result [.cb instate alternate] [info exists ::cb] +} -result {1 0 0 1} + +# See #1257319 +test checkbutton-1.6 "Checkbutton default variable" -body { + destroy .cb ; unset -nocomplain {} ; set result [list] + ttk::checkbutton .cb -onvalue on -offvalue off + lappend result [.cb cget -variable] [info exists .cb] [.cb state] + .cb invoke + lappend result [info exists .cb] [set .cb] [.cb state] + .cb invoke + lappend result [info exists .cb] [set .cb] [.cb state] +} -result [list .cb 0 alternate 1 on selected 1 off {}] + +tcltest::cleanupTests diff --git a/tests/ttk/combobox.test b/tests/ttk/combobox.test new file mode 100644 index 0000000..43f3cf1 --- /dev/null +++ b/tests/ttk/combobox.test @@ -0,0 +1,68 @@ +# +# ttk::combobox widget tests +# + +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +test combobox-1.0 "Combobox tests -- setup" -body { + ttk::combobox .cb +} -result .cb + +test combobox-1.1 "Bad -values list" -body { + .cb configure -values "bad \{list" +} -result "unmatched open brace in list" -returnCodes 1 + +test combobox-1.end "Combobox tests -- cleanup" -body { + destroy .cb +} + +test combobox-2.0 "current command" -body { + ttk::combobox .cb -values [list a b c d e a] + .cb current +} -result -1 + +test combobox-2.1 "current -- set index" -body { + .cb current 5 + .cb get +} -result a + +test combobox-2.2 "current -- change -values" -body { + .cb configure -values [list c b a d e] + .cb current +} -result 2 + +test combobox-2.3 "current -- change value" -body { + .cb set "b" + .cb current +} -result 1 + +test combobox-2.4 "current -- value not in list" -body { + .cb set "z" + .cb current +} -result -1 + +test combobox-2.end "Cleanup" -body { destroy .cb } + + +test combobox-1890211 "ComboboxSelected event after listbox unposted" -body { + # whitebox test... + pack [ttk::combobox .cb -values [list a b c]] + set result [list] + bind .cb <<ComboboxSelected>> { + lappend result Event [winfo ismapped .cb.popdown] [.cb get] + } + lappend result Start 0 [.cb get] + ttk::combobox::Post .cb + lappend result Post [winfo ismapped .cb.popdown] [.cb get] + .cb.popdown.f.l selection clear 0 end; .cb.popdown.f.l selection set 1 + ttk::combobox::LBSelected .cb.popdown.f.l + lappend result Select [winfo ismapped .cb.popdown] [.cb get] + update + set result +} -result [list Start 0 {} Post 1 {} Select 0 b Event 0 b] -cleanup { + destroy .cb +} + +tcltest::cleanupTests diff --git a/tests/ttk/entry.test b/tests/ttk/entry.test new file mode 100644 index 0000000..0c2f0be --- /dev/null +++ b/tests/ttk/entry.test @@ -0,0 +1,283 @@ +# +# Tile package: entry widget tests +# + +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +variable scrollInfo +proc scroll args { + global scrollInfo + set scrollInfo $args +} + +# Some of the tests raise background errors; +# override default bgerror to catch them. +# +variable bgerror "" +proc bgerror {error} { + variable bgerror $error + variable bgerrorInfo $::errorInfo + variable bgerrorCode $::errorCode +} + +# +test entry-1.1 "Create entry widget" -body { + ttk::entry .e +} -result .e + +test entry-1.2 "Insert" -body { + .e insert end abcde + .e get +} -result abcde + +test entry-1.3 "Selection" -body { + .e selection range 1 3 + selection get +} -result bc + +test entry-1.4 "Delete" -body { + .e delete 1 3 + .e get +} -result ade + +test entry-1.5 "Deletion - insert cursor" -body { + .e insert end abcde + .e icursor 0 + .e delete 0 end + .e index insert +} -result 0 + +test entry-1.6 "Deletion - insert cursor at end" -body { + .e insert end abcde + .e icursor end + .e delete 0 end + .e index insert +} -result 0 + +test entry-1.7 "Deletion - insert cursor in the middle " -body { + .e insert end abcde + .e icursor 3 + .e delete 0 end + .e index insert +} -result 0 + +test entry-1.done "Cleanup" -body { destroy .e } + +# Scrollbar tests. + +test entry-2.1 "Create entry before scrollbar" -body { + pack [ttk::entry .te -xscrollcommand [list .tsb set]] \ + -expand true -fill both + pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \ + -expand false -fill x +} -cleanup {destroy .te .tsb} + +test entry-2.2 "Initial scroll position" -body { + ttk::entry .e -font fixed -width 5 -xscrollcommand scroll + .e insert end "0123456789" + pack .e; update + set scrollInfo +} -result {0.0 0.5} -cleanup { destroy .e } +# NOTE: result can vary depending on font. + +# Bounding box / scrolling tests. +test entry-3.0 "Series 3 setup" -body { + ttk::style theme use default + variable fixed fixed + variable cw [font measure $fixed a] + variable ch [font metrics $fixed -linespace] + variable bd 2 ;# border + padding + variable ux [font measure $fixed \u4e4e] + + pack [ttk::entry .e -font $fixed -width 20] + update +} + +test entry-3.1 "bbox widget command" -body { + .e delete 0 end + .e bbox 0 +} -result [list $bd $bd 0 $ch] + +test entry-3.2 "xview" -body { + .e delete 0 end; + .e insert end [string repeat "0" 40] + update idletasks + set result [.e xview] +} -result {0.0 0.5} + +test entry-3.last "Series 3 cleanup" -body { + destroy .e +} + +# Selection tests: + +test entry-4.0 "Selection test - setup" -body { + ttk::entry .e + .e insert end asdfasdf + .e selection range 0 end +} + +test entry-4.1 "Selection test" -body { + selection get +} -result asdfasdf + +test entry-4.2 "Disable -exportselection" -body { + .e configure -exportselection false + selection get +} -returnCodes error -result "PRIMARY selection doesn't exist*" -match glob + +test entry-4.3 "Reenable -exportselection" -body { + .e configure -exportselection true + selection get +} -result asdfasdf + +test entry-4.4 "Force selection loss" -body { + selection own . + .e index sel.first +} -returnCodes error -result "selection isn't in widget .e" + +test entry-4.5 "Allow selection changes if readonly" -body { + .e delete 0 end + .e insert end 0123456789 + .e selection range 0 end + .e configure -state readonly + .e selection range 2 4 + .e configure -state normal + list [.e index sel.first] [.e index sel.last] +} -result {2 4} + +test entry-4.6 "Disallow selection changes if disabled" -body { + .e delete 0 end + .e insert end 0123456789 + .e selection range 0 end + .e configure -state disabled + .e selection range 2 4 + .e configure -state normal + list [.e index sel.first] [.e index sel.last] +} -result {0 10} + +test entry-4.7 {sel.first and sel.last gravity} -body { + set result [list] + .e delete 0 end + .e insert 0 0123456789 + .e select range 2 6 + .e insert 2 XXX + lappend result [.e index sel.first] [.e index sel.last] + .e insert 6 YYY + lappend result [.e index sel.first] [.e index sel.last] [.e get] +} -result {5 9 5 12 01XXX2YYY3456789} + +# Self-destruct tests. + +test entry-5.1 {widget deletion while active} -body { + destroy .e + pack [ttk::entry .e] + update + .e config -xscrollcommand { destroy .e } + update idletasks + winfo exists .e +} -result 0 + +# TODO: test killing .e in -validatecommand, -invalidcommand, variable trace; + + +# -textvariable tests. + +test entry-6.1 {Update linked variable in write trace} -body { + proc override args { + global x + set x "Overridden!" + } + catch {destroy .e} + set x "" + trace variable x w override + ttk::entry .e -textvariable x + .e insert 0 "Some text" + set result [list $x [.e get]] + set result +} -result {Overridden! Overridden!} -cleanup { + unset x + rename override {} + destroy .e +} + +test entry-6.2 {-textvariable tests} -body { + set result [list] + ttk::entry .e -textvariable x + set x "text" + lappend result [.e get] + unset x + lappend result [.e get] + .e insert end "newtext" + lappend result [.e get] [set x] +} -result [list "text" "" "newtext" "newtext"] -cleanup { + destroy .e + unset -nocomplain x +} + +test entry-7.1 {Bad style options} -body { + ttk::style theme create entry-7.1 -settings { + ttk::style configure TEntry -foreground BadColor + ttk::style map TEntry -foreground {readonly AnotherBadColor} + ttk::style map TEntry -font {readonly ABadFont} + ttk::style map TEntry \ + -selectbackground {{} BadColor} \ + -selectforeground {{} BadColor} \ + -insertcolor {{} BadColor} + } + pack [ttk::entry .e -text "Don't crash"] + ttk::style theme use entry-7.1 + update + .e selection range 0 end + update + .e state readonly; + update +} -cleanup { destroy .e ; ttk::style theme use default } + +test entry-8.1 "Unset linked variable" -body { + variable foo "bar" + pack [ttk::entry .e -textvariable foo] + unset foo + .e insert end "baz" + list [.e cget -textvariable] [.e get] [set foo] +} -result [list foo "baz" "baz"] -cleanup { destroy .e } + +test entry-8.2 "Unset linked variable by deleting namespace" -body { + namespace eval ::test { variable foo "bar" } + pack [ttk::entry .e -textvariable ::test::foo] + namespace delete ::test + .e insert end "baz" ;# <== error here + list [.e cget -textvariable] [.e get] [set foo] +} -returnCodes error -result "*parent namespace doesn't exist*" -match glob +# '-result [list ::test::foo "baz" "baz"]' would also be sensible, +# but Tcl namespaces don't work that way. + +test entry-8.2a "Followup to test 8.2" -body { + .e cget -textvariable +} -result ::test::foo -cleanup { destroy .e } +# For 8.2a, -result {} would also be sensible. + +test entry-9.1 "Index range invariants" -setup { + # See bug#1721532 for discussion + proc entry-9.1-trace {n1 n2 op} { + set ::V NO! + } + variable V + trace add variable V write entry-9.1-trace + ttk::entry .e -textvariable V +} -body { + set result [list] + .e insert insert a ; lappend result [.e index insert] [.e index end] + .e insert insert b ; lappend result [.e index insert] [.e index end] + .e insert insert c ; lappend result [.e index insert] [.e index end] + .e insert insert d ; lappend result [.e index insert] [.e index end] + .e insert insert e ; lappend result [.e index insert] [.e index end] + set result +} -result [list 1 3 2 3 3 3 3 3 3 3] -cleanup { + unset V + destroy .e +} + +tcltest::cleanupTests diff --git a/tests/ttk/image.test b/tests/ttk/image.test new file mode 100644 index 0000000..a55f7f8 --- /dev/null +++ b/tests/ttk/image.test @@ -0,0 +1,50 @@ +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +test image-1.1 "Bad image element" -body { + ttk::style element create BadImage image badimage +} -returnCodes error -result {image "badimage" doesn't exist} + +test image-1.2 "Duplicate element" -setup { + image create photo test.element -width 10 -height 10 + ttk::style element create testElement image test.element +} -body { + ttk::style element create testElement image test.element +} -returnCodes 1 -result "Duplicate element testElement" + +test image-2.0 "Deletion of displayed image (label)" -setup { + image create photo test.image -width 10 -height 10 +} -body { + pack [set w [ttk::label .ttk_image20 -image test.image]] + tkwait visibility $w + image delete test.image + update +} -cleanup { + destroy .ttk_image20 +} -result {} + +test image-2.1 "Deletion of displayed image (checkbutton)" -setup { + image create photo test.image -width 10 -height 10 +} -body { + pack [set w [ttk::checkbutton .ttk_image21 -image test.image]] + tkwait visibility $w + image delete test.image + update +} -cleanup { + destroy .ttk_image21 +} -result {} + +test image-2.2 "Deletion of displayed image (radiobutton)" -setup { + image create photo test.image -width 10 -height 10 +} -body { + pack [set w [ttk::radiobutton .ttk_image22 -image test.image]] + tkwait visibility $w + image delete test.image + update +} -cleanup { + destroy .ttk_image22 +} -result {} + +# +tcltest::cleanupTests diff --git a/tests/ttk/labelframe.test b/tests/ttk/labelframe.test new file mode 100644 index 0000000..28b4d2e --- /dev/null +++ b/tests/ttk/labelframe.test @@ -0,0 +1,130 @@ +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +test labelframe-1.0 "Setup" -body { + pack [ttk::labelframe .lf] -expand true -fill both +} + +test labelframe-2.1 "Can't use indirect descendant as labelwidget" -body { + ttk::frame .lf.t + ttk::checkbutton .lf.t.cb + .lf configure -labelwidget .lf.t.cb +} -returnCodes 1 -result "can't *" -match glob \ + -cleanup { destroy .lf.t } ; + +test labelframe-2.2 "Can't use toplevel as labelwidget" -body { + toplevel .lf.t + .lf configure -labelwidget .lf.t +} -returnCodes 1 -result "can't *" -match glob \ + -cleanup { destroy .lf.t } ; + +test labelframe-2.3 "Can't use non-windows as -labelwidget" -body { + .lf configure -labelwidget BogusWindowName +} -returnCodes 1 -result {bad window path name "BogusWindowName"} + +test labelframe-2.4 "Can't use nonexistent-windows as -labelwidget" -body { + .lf configure -labelwidget .nosuchwindow +} -returnCodes 1 -result {bad window path name ".nosuchwindow"} + + +### +# See also series labelframe-4.x +# +test labelframe-3.1 "Add child slave" -body { + checkbutton .lf.cb -text "abcde" + .lf configure -labelwidget .lf.cb + list [update; winfo viewable .lf.cb] [winfo manager .lf.cb] +} -result [list 1 labelframe] + +test labelframe-3.2 "Remove child slave" -body { + .lf configure -labelwidget {} + list [update; winfo viewable .lf.cb] [winfo manager .lf.cb] +} -result [list 0 {}] + +test labelframe-3.3 "Re-add child slave" -body { + .lf configure -labelwidget .lf.cb + list [update; winfo viewable .lf.cb] [winfo manager .lf.cb] +} -result [list 1 labelframe] + +test labelframe-3.4 "Re-manage child slave" -body { + pack .lf.cb -side right + list [update; winfo viewable .lf.cb] [winfo manager .lf.cb] [.lf cget -labelwidget] +} -result [list 1 pack {}] + +test labelframe-3.5 "Re-add child slave" -body { + .lf configure -labelwidget .lf.cb + list [update; winfo viewable .lf.cb] [winfo manager .lf.cb] +} -result [list 1 labelframe] + +test labelframe-3.6 "Destroy child slave" -body { + destroy .lf.cb + .lf cget -labelwidget +} -result {} + +### +# Re-run series labelframe-3.x with nonchild slaves. +# +# @@@ ODDITY, 14 Nov 2005: +# @@@ labelframe-4.1 fails if .cb is a [checkbutton], +# @@@ but seems to succeed if it's some other widget class. +# @@@ I suspect a race condition; unable to track it down ATM. +# +# @@@ FOLLOWUP: This *may* have been caused by a bug in ManagerIdleProc +# @@@ (see manager.c r1.11). There's still probably a race condition in here. +# +test labelframe-4.1 "Add nonchild slave" -body { + checkbutton .cb -text "abcde" + .lf configure -labelwidget .cb + update + list [winfo ismapped .cb] [winfo viewable .cb] [winfo manager .cb] + +} -result [list 1 1 labelframe] + +test labelframe-4.2 "Remove nonchild slave" -body { + .lf configure -labelwidget {} + update; + list [winfo ismapped .cb] [winfo viewable .cb] [winfo manager .cb] +} -result [list 0 0 {}] + +test labelframe-4.3 "Re-add nonchild slave" -body { + .lf configure -labelwidget .cb + list [update; winfo viewable .cb] [winfo manager .cb] +} -result [list 1 labelframe] + +test labelframe-4.4 "Re-manage nonchild slave" -body { + pack .cb -side right + list [update; winfo viewable .cb] \ + [winfo manager .cb] \ + [.lf cget -labelwidget] +} -result [list 1 pack {}] + +test labelframe-4.5 "Re-add nonchild slave" -body { + .lf configure -labelwidget .cb + list [update; winfo viewable .cb] \ + [winfo manager .cb] \ + [.lf cget -labelwidget] +} -result [list 1 labelframe .cb] + +test labelframe-4.6 "Destroy nonchild slave" -body { + destroy .cb + .lf cget -labelwidget +} -result {} + +test labelframe-5.0 "Cleanup" -body { + destroy .lf +} + +# 1342876 -- labelframe should raise sibling -labelwidget above self. +# +test labelframe-6.1 "Stacking order" -body { + toplevel .t + pack [ttk::checkbutton .t.x1] + pack [ttk::labelframe .t.lf -labelwidget [ttk::label .t.lb]] + pack [ttk::checkbutton .t.x2] + winfo children .t +} -cleanup { + destroy .t +} -result [list .t.x1 .t.lf .t.lb .t.x2] + +tcltest::cleanupTests diff --git a/tests/ttk/layout.test b/tests/ttk/layout.test new file mode 100644 index 0000000..814e1d9 --- /dev/null +++ b/tests/ttk/layout.test @@ -0,0 +1,25 @@ +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +test layout-1.1 "Size computations for mixed-orientation layouts" -body { + ttk::style theme use default + + set block [image create photo -width 10 -height 10] + ttk::style element create block image $block + ttk::style layout Blocks { + border -children { block } -side left + border -children { block } -side top + border -children { block } -side bottom + } + ttk::style configure Blocks -borderwidth 1 -relief raised + ttk::button .b -style Blocks + + pack .b -expand true -fill both + + list [winfo reqwidth .b] [winfo reqheight .b] + +} -cleanup { destroy .b } -result [list 24 24] + + +tcltest::cleanupTests diff --git a/tests/ttk/notebook.test b/tests/ttk/notebook.test new file mode 100644 index 0000000..cdce020 --- /dev/null +++ b/tests/ttk/notebook.test @@ -0,0 +1,493 @@ +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +test notebook-1.0 "Setup" -body { + ttk::notebook .nb +} -result .nb + +# +# Error handling tests: +# +test notebook-1.1 "Cannot add ancestor" -body { + .nb add . +} -returnCodes error -result "*" -match glob + +proc inoperative {args} {} + +inoperative test notebook-1.2 "Cannot add siblings" -body { + # This is legal now + .nb add [frame .sibling] +} -returnCodes error -result "*" -match glob + +test notebook-1.3 "Cannot add toplevel" -body { + .nb add [toplevel .nb.t] +} -cleanup { + destroy .t.nb +} -returnCodes 1 -match glob -result "can't add .nb.t*" + +test notebook-1.4 "Try to select bad tab" -body { + .nb select @6000,6000 +} -returnCodes 1 -match glob -result "* not found" + +# +# Now add stuff: +# +test notebook-2.0 "Add children" -body { + pack .nb -expand true -fill both + .nb add [frame .nb.foo] -text "Foo" + pack [label .nb.foo.l -text "Foo"] + + .nb add [frame .nb.bar -relief raised -borderwidth 2] -text "Bar" + pack [label .nb.bar.l -text "Bar"] + + .nb tabs +} -result [list .nb.foo .nb.bar] + +test notebook-2.1 "select pane" -body { + .nb select .nb.foo + update + list [winfo viewable .nb.foo] [winfo viewable .nb.bar] [.nb index current] +} -result [list 1 0 0] + +test notebook-2.2 "select another pane" -body { + .nb select 1 + update + list [winfo viewable .nb.foo] [winfo viewable .nb.bar] [.nb index current] +} -result [list 0 1 1] + +test notebook-2.3 "tab - get value" -body { + .nb tab .nb.foo -text +} -result "Foo" + +test notebook-2.4 "tab - set value" -body { + .nb tab .nb.foo -text "Changed Foo" + .nb tab .nb.foo -text +} -result "Changed Foo" + +test notebook-2.5 "tab - get all options" -body { + .nb tab .nb.foo +} -result [list \ + -padding 0 -sticky nsew \ + -state normal -text "Changed Foo" -image "" -compound none -underline -1] + +test notebook-4.1 "Test .nb index end" -body { + .nb index end +} -result 2 + +test notebook-4.2 "'end' is not a selectable index" -body { + .nb select end +} -returnCodes error -result "*" -match glob + +test notebook-4.3 "Select index out of range" -body { + .nb select 2 +} -returnCodes error -result "*" -match glob + +test notebook-4.4 "-padding option" -body { + .nb configure -padding "5 5 5 5" +} + +test notebook-4.end "Cleanup test suite 1-4.*" -body { destroy .nb } + +test notebook-5.1 "Virtual events" -body { + toplevel .t + set ::events [list] + bind .t <<NotebookTabChanged>> { lappend events changed %W } + + pack [set nb [ttk::notebook .t.nb]] -expand true -fill both; update + $nb add [frame $nb.f1] + $nb add [frame $nb.f2] + $nb add [frame $nb.f3] + + $nb select $nb.f1 + update; set events +} -result [list changed .t.nb] + +test notebook-5.2 "Virtual events, continued" -body { + set events [list] + $nb select $nb.f3 + update ; set events +} -result [list changed .t.nb] +# OR: [list deselected .t.nb.f1 selected .t.nb.f3 changed .t.nb] + +test notebook-5.3 "Disabled tabs" -body { + set events [list] + $nb tab $nb.f2 -state disabled + $nb select $nb.f2 + update + list $events [$nb index current] +} -result [list [list] 2] + +test notebook-5.4 "Reenable tab" -body { + set events [list] + $nb tab $nb.f2 -state normal + $nb select $nb.f2 + update + list $events [$nb index current] +} -result [list [list changed .t.nb] 1] + +test notebook-5.end "Virtual events, cleanup" -body { destroy .t } + +test notebook-6.0 "Select hidden tab" -setup { + set nb [ttk::notebook .nb] + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb select $nb.f2 +} -cleanup { + destroy $nb +} -body { + set result [list] + $nb tab $nb.f1 -state hidden + lappend result [$nb tab $nb.f1 -state] + $nb select $nb.f1 + lappend result [$nb tab $nb.f1 -state] +} -result [list hidden normal] + +test notebook-6.1 "Hide selected tab" -setup { + pack [set nb [ttk::notebook .nb]] ; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f2 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f2] + $nb hide $nb.f2 + lappend result [$nb index current] [winfo ismapped $nb.f2] + update idletasks; lappend result [winfo ismapped $nb.f3] +} -result [list 1 1 2 0 1] + +# See 1370833 +test notebook-6.2 "Forget selected tab" -setup { + ttk::notebook .n + pack .n + label .n.l -text abc + .n add .n.l +} -body { + update + after 100 + .n forget .n.l + update ;# Yowch! +} -cleanup { + destroy .n +} -result {} + +test notebook-6.3 "Hide first tab when it's the current" -setup { + pack [set nb [ttk::notebook .nb]] ; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f1 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f1] + $nb hide $nb.f1 + lappend result [$nb index current] [winfo ismapped $nb.f1] +} -result [list 0 1 1 0] + +test notebook-6.4 "Forget first tab when it's the current" -setup { + pack [set nb [ttk::notebook .nb]] ; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f1 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f1] + $nb forget $nb.f1 + lappend result [$nb index current] [winfo ismapped $nb.f1] +} -result [list 0 1 0 0] + +test notebook-6.5 "Hide last tab when it's the current" -setup { + pack [set nb [ttk::notebook .nb]] ; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f3 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f3] + $nb hide $nb.f3 + lappend result [$nb index current] [winfo ismapped $nb.f3] +} -result [list 2 1 1 0] + +test notebook-6.6 "Forget a middle tab when it's the current" -setup { + pack [set nb [ttk::notebook .nb]] ; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f2 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f2] + $nb forget $nb.f2 + lappend result [$nb index current] [winfo ismapped $nb.f2] +} -result [list 1 1 1 0] + +test notebook-6.7 "Hide a middle tab when it's the current" -setup { + pack [set nb [ttk::notebook .nb]]; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f2 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f2] + $nb hide $nb.f2 + lappend result [$nb index current] [winfo ismapped $nb.f2] +} -result [list 1 1 2 0] + +test notebook-6.8 "Forget a non-current tab < current" -setup { + pack [set nb [ttk::notebook .nb]] ; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f2 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f2] + $nb forget $nb.f1 + lappend result [$nb index current] [winfo ismapped $nb.f2] +} -result [list 1 1 0 1] + +test notebook-6.9 "Hide a non-current tab < current" -setup { + pack [set nb [ttk::notebook .nb]] ; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f2 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f2] + $nb hide $nb.f1 + lappend result [$nb index current] [winfo ismapped $nb.f2] +} -result [list 1 1 1 1] + +test notebook-6.10 "Forget a non-current tab > current" -setup { + pack [set nb [ttk::notebook .nb]] ; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f2 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f2] + $nb forget $nb.f3 + lappend result [$nb index current] [winfo ismapped $nb.f2] +} -result [list 1 1 1 1] + +test notebook-6.11 "Hide a non-current tab > current" -setup { + pack [set nb [ttk::notebook .nb]]; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f2 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [winfo ismapped $nb.f2] + $nb hide $nb.f3 + lappend result [$nb index current] [winfo ismapped $nb.f2] +} -result [list 1 1 1 1] + +test notebook-6.12 "Hide and re-add a tab" -setup { + pack [set nb [ttk::notebook .nb]]; update + $nb add [ttk::frame $nb.f1] + $nb add [ttk::frame $nb.f2] + $nb add [ttk::frame $nb.f3] + $nb select $nb.f2 +} -cleanup { + destroy $nb +} -body { + set result [list] + lappend result [$nb index current] [$nb tab $nb.f2 -state] + $nb hide $nb.f2 + lappend result [$nb index current] [$nb tab $nb.f2 -state] + $nb add $nb.f2 + lappend result [$nb index current] [$nb tab $nb.f2 -state] +} -result [list 1 normal 2 hidden 2 normal] + +# +# Insert: +# +unset nb +test notebook-7.0 "insert - setup" -body { + pack [ttk::notebook .nb] + for {set i 0} {$i < 5} {incr i} { + .nb add [ttk::frame .nb.f$i] -text "$i" + } + .nb select .nb.f1 + list [.nb index current] [.nb tabs] +} -result [list 1 [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]] + +test notebook-7.1 "insert - move backwards" -body { + .nb insert 1 3 + list [.nb index current] [.nb tabs] +} -result [list 2 [list .nb.f0 .nb.f3 .nb.f1 .nb.f2 .nb.f4]] + +test notebook-7.2 "insert - move backwards again" -body { + .nb insert 1 3 + list [.nb index current] [.nb tabs] +} -result [list 3 [list .nb.f0 .nb.f2 .nb.f3 .nb.f1 .nb.f4]] + +test notebook-7.3 "insert - move backwards again" -body { + .nb insert 1 3 + list [.nb index current] [.nb tabs] +} -result [list 1 [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]] + +test notebook-7.4 "insert - move forwards" -body { + .nb insert 3 1 + list [.nb index current] [.nb tabs] +} -result [list 3 [list .nb.f0 .nb.f2 .nb.f3 .nb.f1 .nb.f4]] + +test notebook-7.5 "insert - move forwards again" -body { + .nb insert 3 1 + list [.nb index current] [.nb tabs] +} -result [list 2 [list .nb.f0 .nb.f3 .nb.f1 .nb.f2 .nb.f4]] + +test notebook-7.6 "insert - move forwards again" -body { + .nb insert 3 1 + list [.nb index current] [.nb tabs] +} -result [list 1 [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]] + +test notebook-7.7a "insert - current tab undisturbed" -body { + .nb select 0 + .nb insert 3 1 + .nb index current +} -result 0 + +test notebook-7.7b "insert - current tab undisturbed" -body { + .nb select 0 + .nb insert 1 3 + .nb index current +} -result 0 + +test notebook-7.7c "insert - current tab undisturbed" -body { + .nb select 4 + .nb insert 3 1 + .nb index current +} -result 4 + +test notebook-7.7d "insert - current tab undisturbed" -body { + .nb select 4 + .nb insert 1 3 + .nb index current +} -result 4 + +test notebook-7.8a "move tabs - current tab undisturbed - exhaustive" -body { + .nb select .nb.f0 + foreach i {0 1 2 3 4} { + .nb insert $i .nb.f$i + } + + foreach i {0 1 2 3 4} { + .nb select .nb.f$i + foreach j {0 1 2 3 4} { + foreach k {0 1 2 3 4} { + .nb insert $j $k + set current [lindex [.nb tabs] [.nb index current]] + if {$current != ".nb.f$i"} { + error "($i,$j,$k) current = $current" + } + .nb insert $k $j + if {[.nb tabs] ne [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]} { + error "swap $j $k; swap $k $j => [.nb tabs]" + } + } + } + } + .nb tabs +} -result [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4] + +test notebook-7.8b "insert new - current tab undisturbed - exhaustive" -body { + foreach i {0 1 2 3 4} { + .nb select .nb.f$i + foreach j {0 1 2 3 4} { +.nb select .nb.f$i + .nb insert $j [frame .nb.newf] + set current [lindex [.nb tabs] [.nb index current]] + if {$current != ".nb.f$i"} { + puts stderr "new tab at $j, current = $current, expect .nb.f$i" + } + destroy .nb.newf + if {[.nb tabs] ne [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]} { + error "tabs disturbed" + } + } + } +} + +test notebook-7.end "insert - cleanup" -body { + destroy .nb +} + +test notebook-1817596-1 "insert should autoselect first tab" -body { + pack [ttk::notebook .nb] + list \ + [.nb insert end [ttk::label .nb.l1 -text One] -text One] \ + [.nb select] \ + ; +} -result [list "" .nb.l1] -cleanup { destroy .nb } + +test notebook-1817596-2 "error in insert should have no effect" -body { + pack [ttk::notebook .nb] + .nb insert end [ttk::label .nb.l1] + .nb insert end [ttk::label .nb.l2] + list \ + [catch { .nb insert .l2 0 -badoption badvalue } err] \ + [.nb tabs] \ +} -result [list 1 [list .nb.l1 .nb.l2]] -cleanup { destroy .nb } + +test notebook-1817596-3 "insert/configure" -body { + pack [ttk::notebook .nb] + .nb insert end [ttk::label .nb.l0] -text "L0" + .nb insert end [ttk::label .nb.l1] -text "L1" + .nb insert end [ttk::label .nb.l2] -text "XX" + .nb insert 0 2 -text "L2" + + list [.nb tabs] [.nb tab 0 -text] [.nb tab 1 -text] [.nb tab 2 -text] + +} -result [list [list .nb.l2 .nb.l0 .nb.l1] L2 L0 L1] -cleanup { destroy .nb } + + +# See #1343984 +test notebook-1343984-1 "don't autoselect on destroy - setup" -body { + ttk::notebook .nb + set ::history [list] + bind TestFrame <Map> { lappend history MAP %W } + bind TestFrame <Destroy> { lappend history DESTROY %W } + .nb add [ttk::frame .nb.frame1 -class TestFrame] -text "Frame 1" + .nb add [ttk::frame .nb.frame2 -class TestFrame] -text "Frame 2" + .nb add [ttk::frame .nb.frame3 -class TestFrame] -text "Frame 3" + pack .nb -fill both -expand 1 + update + set ::history +} -result [list MAP .nb.frame1] + +test notebook-1343984-2 "don't autoselect on destroy" -body { + set ::history [list] + destroy .nb + update + set ::history +} -result [list DESTROY .nb.frame1 DESTROY .nb.frame2 DESTROY .nb.frame3] + +tcltest::cleanupTests diff --git a/tests/ttk/panedwindow.test b/tests/ttk/panedwindow.test new file mode 100644 index 0000000..7fe5c87 --- /dev/null +++ b/tests/ttk/panedwindow.test @@ -0,0 +1,291 @@ +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +proc propagate-geometry {} { update idletasks } + +# Basic sanity checks: +# +test panedwindow-1.0 "Setup" -body { + ttk::panedwindow .pw +} -result .pw + +test panedwindow-1.1 "Make sure empty panedwindow doesn't crash" -body { + pack .pw -expand true -fill both + update +} + +test panedwindow-1.2 "Add a pane" -body { + .pw add [ttk::frame .pw.f1] + winfo manager .pw.f1 +} -result "panedwindow" + +test panedwindow-1.3 "Steal pane" -body { + pack .pw.f1 -side bottom + winfo manager .pw.f1 +} -result "pack" + +test panedwindow-1.4 "Make sure empty panedwindow still doesn't crash" -body { + update +} + +test panedwindow-1.5 "Remanage pane" -body { + #XXX .pw insert 0 .pw.f1 + .pw add .pw.f1 + winfo manager .pw.f1 +} -result "panedwindow" + +test panedwindow-1.6 "Forget pane" -body { + .pw forget .pw.f1 + winfo manager .pw.f1 +} -result "" + +test panedwindow-1.7 "Make sure empty panedwindow still still doesn't crash" -body { + update +} + +test panedwindow-1.8 "Re-forget pane" -body { + .pw forget .pw.f1 +} -returnCodes 1 -result ".pw.f1 is not managed by .pw" + +test panedwindow-1.end "Cleanup" -body { + destroy .pw +} + +# Resize behavior: +# +test panedwindow-2.1 "..." -body { + ttk::panedwindow .pw -orient horizontal + + .pw add [listbox .pw.l1] + .pw add [listbox .pw.l2] + .pw add [listbox .pw.l3] + .pw add [listbox .pw.l4] + + pack .pw -expand true -fill both + update + set w1 [winfo width .] + + # This should make the window shrink: + destroy .pw.l2 + + update + set w2 [winfo width .] + + expr {$w2 < $w1} +} -result 1 + +test panedwindow-2.2 "..., cont'd" -body { + + # This should keep the window from shrinking: + wm geometry . [wm geometry .] + + set rw2 [winfo reqwidth .pw] + + destroy .pw.l1 + update + + set w3 [winfo width .] + set rw3 [winfo reqwidth .pw] + + expr {$w3 == $w2 && $rw3 < $rw2} + # problem: [winfo reqwidth] shrinks, but sashes haven't moved + # since we haven't gotten a ConfigureNotify. + # How to (a) check for this, and (b) fix it? +} -result 1 + +test panedwindow-2.3 "..., cont'd" -body { + + .pw add [listbox .pw.l5] + update + set rw4 [winfo reqwidth .pw] + + expr {$rw4 > $rw3} +} -result 1 + +test panedwindow-2.end "Cleanup" -body { destroy .pw } + +# +# ... +# +test panedwindow-3.0 "configure pane" -body { + ttk::panedwindow .pw + .pw add [listbox .pw.lb1] + .pw add [listbox .pw.lb2] + .pw pane 1 -weight 2 + .pw pane 1 -weight +} -result 2 + +test panedwindow-3.1 "configure pane -- errors" -body { + .pw pane 1 -weight -4 +} -returnCodes 1 -match glob -result "-weight must be nonnegative" + +test panedwindow-3.2 "add pane -- errors" -body { + .pw add [ttk::label .pw.l] -weight -1 +} -returnCodes 1 -match glob -result "-weight must be nonnegative" + + +test panedwindow-3.end "cleanup" -body { destroy .pw } + + +test panedwindow-4.1 "forget" -body { + pack [ttk::panedwindow .pw -orient vertical] -expand true -fill both + .pw add [label .pw.l1 -text "L1"] + .pw add [label .pw.l2 -text "L2"] + .pw add [label .pw.l3 -text "L3"] + .pw add [label .pw.l4 -text "L4"] + + update + + .pw forget .pw.l1 + .pw forget .pw.l2 + .pw forget .pw.l3 + .pw forget .pw.l4 + update +} + +test panedwindow-4.2 "forget forgotten" -body { + .pw forget .pw.l1 +} -returnCodes 1 -result ".pw.l1 is not managed by .pw" + +# checkorder $winlist -- +# Ensure that Y coordinates windows in $winlist are strictly increasing. +# +proc checkorder {winlist} { + set pos -1 + set positions [list] + foreach win $winlist { + lappend positions [set nextpos [winfo y $win]] + if {$nextpos <= $pos} { + error "window $win out of order ($positions)" + } + set pos $nextpos + } +} + +test panedwindow-4.3 "insert command" -body { + .pw insert end .pw.l1 + .pw insert end .pw.l3 + .pw insert 1 .pw.l2 + .pw insert end .pw.l4 + + update; + checkorder {.pw.l1 .pw.l2 .pw.l3 .pw.l4} +} + +test panedwindow-4.END "cleanup" -body { + destroy .pw +} + +# See #1292219 + +test panedwindow-5.1 "Propagate Map/Unmap state to children" -body { + set result [list] + pack [ttk::panedwindow .pw] + .pw add [ttk::button .pw.b] + update + + lappend result [winfo ismapped .pw] [winfo ismapped .pw.b] + + pack forget .pw + update + lappend result [winfo ismapped .pw] [winfo ismapped .pw.b] + + set result +} -result [list 1 1 0 0] -cleanup { + destroy .pw +} + +### sashpos tests. +# +proc sashpositions {pw} { + set positions [list] + set npanes [llength [winfo children $pw]] + for {set i 0} {$i < $npanes - 1} {incr i} { + lappend positions [$pw sashpos $i] + } + return $positions +} + +test paned-sashpos-setup "Setup for sash position test" -body { + ttk::style theme use default + ttk::style configure -sashthickness 5 + + ttk::panedwindow .pw + .pw add [frame .pw.f1 -width 20 -height 20] + .pw add [frame .pw.f2 -width 20 -height 20] + .pw add [frame .pw.f3 -width 20 -height 20] + .pw add [frame .pw.f4 -width 20 -height 20] + + propagate-geometry + list [winfo reqwidth .pw] [winfo reqheight .pw] +} -result [list 20 [expr {20*4 + 5*3}]] + +test paned-sashpos-attempt-restore "Attempt to set sash positions" -body { + # This is not expected to succeed, since .pw isn't large enough yet. + # + .pw sashpos 0 30 + .pw sashpos 1 60 + .pw sashpos 2 90 + + list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw] +} -result [list 20 95 [list 0 5 10]] + +test paned-sashpos-restore "Set height then sash positions" -body { + # Setting sash positions after setting -height _should_ succeed. + # + .pw configure -height 120 + .pw sashpos 0 30 + .pw sashpos 1 60 + .pw sashpos 2 90 + list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw] +} -result [list 20 120 [list 30 60 90]] + +test paned-sashpos-cleanup "Clean up" -body { destroy .pw } + +test paned-propagation-setup "Setup." -body { + ttk::style theme use default + ttk::style configure -sashthickness 5 + wm geometry . {} + ttk::panedwindow .pw -orient vertical + + frame .pw.f1 -width 100 -height 50 + frame .pw.f2 -width 100 -height 50 + + list [winfo reqwidth .pw.f1] [winfo reqheight .pw.f1] +} -result [list 100 50] + +test paned-propagation-1 "Initial request size" -body { + .pw add .pw.f1 + .pw add .pw.f2 + propagate-geometry + list [winfo reqwidth .pw] [winfo reqheight .pw] +} -result [list 100 105] + +test paned-propagation-2 "Slave change before map" -body { + .pw.f1 configure -width 200 -height 100 + propagate-geometry + list [winfo reqwidth .pw] [winfo reqheight .pw] +} -result [list 200 155] + +test paned-propagation-3 "Map window" -body { + pack .pw -expand true -fill both + update + list [winfo width .pw] [winfo height .pw] [.pw sashpos 0] +} -result [list 200 155 100] + +test paned-propagation-4 "Slave change after map, off-axis" -body { + .pw.f1 configure -width 100 ;# should be granted + propagate-geometry + list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0] +} -result [list 100 155 100] + +test paned-propagation-5 "Slave change after map, on-axis" -body { + .pw.f1 configure -height 50 ;# should be denied + propagate-geometry + list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0] +} -result [list 100 155 100] + +test paned-propagation-cleanup "Clean up." -body { destroy .pw } + +tcltest::cleanupTests diff --git a/tests/ttk/progressbar.test b/tests/ttk/progressbar.test new file mode 100644 index 0000000..b9add86 --- /dev/null +++ b/tests/ttk/progressbar.test @@ -0,0 +1,85 @@ +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + + +test progressbar-1.1 "Setup" -body { + ttk::progressbar .pb +} -result .pb + +test progressbar-1.2 "Linked variable" -body { + set PB 50 + .pb configure -variable PB + .pb cget -value +} -result 50 + +test progressbar-1.3 "Change linked variable" -body { + set PB 80 + .pb cget -value +} -result 80 + +test progressbar-1.4 "Set linked variable to bad value" -body { + set PB "bogus" + .pb instate invalid +} -result 1 + +test progressbar-1.4.1 "Set linked variable back to a good value" -body { + set PB 80 + .pb instate invalid +} -result 0 + +test progressbar-1.5 "Set -variable to illegal variable" -body { + set BAD "bogus" + .pb configure -variable BAD + .pb instate invalid +} -result 1 + +test progressbar-1.6 "Unset -variable" -body { + unset -nocomplain UNSET + .pb configure -variable UNSET + .pb instate disabled +} -result 1 + +test progressbar-2.0 "step command" -body { + .pb configure -variable {} ;# @@@ + .pb configure -value 5 -maximum 10 -mode determinate + .pb step + .pb cget -value +} -result 6.0 + +test progressbar-2.1 "step command, with stepamount" -body { + .pb step 3 + .pb cget -value +} -result 9.0 + +test progressbar-2.2 "step wraps at -maximum in determinate mode" -body { + .pb step + .pb cget -value +} -result 0.0 + +test progressbar-2.3 "step doesn't wrap in indeterminate mode" -body { + .pb configure -value 8 -maximum 10 -mode indeterminate + .pb step + .pb step + .pb step + .pb cget -value +} -result 11.0 + +test progressbar-2.4 "step with linked variable" -body { + .pb configure -variable PB ;# @@@ + set PB 5 + .pb step + set PB +} -result 6.0 + +test progressbar-2.5 "error in write trace" -body { + trace variable PB w { error "YIPES!" ;# } + .pb step + set PB ;# NOTREACHED +} -cleanup { unset PB } -returnCodes 1 -match glob -result "*YIPES!" + +test progressbar-end "Cleanup" -body { + destroy .pb +} + +tcltest::cleanupTests diff --git a/tests/ttk/radiobutton.test b/tests/ttk/radiobutton.test new file mode 100644 index 0000000..ba02954 --- /dev/null +++ b/tests/ttk/radiobutton.test @@ -0,0 +1,48 @@ +# +# ttk::radiobutton widget tests. +# + +package require Tk +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +test radiobutton-1.1 "Radiobutton check" -body { + pack \ + [ttk::radiobutton .rb1 -text "One" -variable choice -value 1] \ + [ttk::radiobutton .rb2 -text "Two" -variable choice -value 2] \ + [ttk::radiobutton .rb3 -text "Three" -variable choice -value 3] \ + ; +} +test radiobutton-1.2 "Radiobutton invoke" -body { + .rb1 invoke + set ::choice +} -result 1 + +test radiobutton-1.3 "Radiobutton state" -body { + .rb1 instate selected +} -result 1 + +test radiobutton-1.4 "Other radiobutton invoke" -body { + .rb2 invoke + set ::choice +} -result 2 + +test radiobutton-1.5 "Other radiobutton state" -body { + .rb2 instate selected +} -result 1 + +test radiobutton-1.6 "First radiobutton state" -body { + .rb1 instate selected +} -result 0 + +test radiobutton-1.7 "Unset radiobutton variable" -body { + unset ::choice + list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate] +} -result {0 1 1} + +test radiobutton-1.8 "Reset radiobutton variable" -body { + set ::choice 2 + list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate] +} -result {1 0 0} + +tcltest::cleanupTests diff --git a/tests/ttk/scrollbar.test b/tests/ttk/scrollbar.test new file mode 100644 index 0000000..0464273 --- /dev/null +++ b/tests/ttk/scrollbar.test @@ -0,0 +1,69 @@ +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +testConstraint coreScrollbar [expr {[tk windowingsystem] eq "aqua"}] + +test scrollbar-swapout-1 "Use core scrollbars on OSX..." -constraints { + coreScrollbar +} -body { + ttk::scrollbar .sb -command "yadda" + list [winfo class .sb] [.sb cget -command] +} -result [list Scrollbar yadda] -cleanup { + destroy .sb +} + +test scrollbar-swapout-2 "... unless -style is specified ..." -constraints { + coreScrollbar +} -body { + ttk::style layout Vertical.Custom.TScrollbar \ + [ttk::style layout Vertical.TScrollbar] ; # See #1833339 + ttk::scrollbar .sb -command "yadda" -style Custom.TScrollbar + list [winfo class .sb] [.sb cget -command] [.sb cget -style] +} -result [list TScrollbar yadda Custom.TScrollbar] -cleanup { + destroy .sb +} + +test scrollbar-swapout-3 "... or -class." -constraints { + coreScrollbar +} -body { + ttk::scrollbar .sb -command "yadda" -class Custom.TScrollbar + list [winfo class .sb] [.sb cget -command] +} -result [list Custom.TScrollbar yadda] -cleanup { + destroy .sb +} + +test scrollbar-1.0 "Setup" -body { + ttk::scrollbar .tsb +} -result .tsb + +test scrollbar-1.1 "Set method" -body { + .tsb set 0.2 0.4 + .tsb get +} -result [list 0.2 0.4] + +test scrollbar-1.2 "Set orientation" -body { + .tsb configure -orient vertical + set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb] + expr {$h > $w} +} -result 1 + +test scrollbar-1.3 "Change orientation" -body { + .tsb configure -orient horizontal + set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb] + expr {$h < $w} +} -result 1 + +# +# Scale tests: +# + +test scale-1.0 "Self-destruction" -body { + trace variable v w { destroy .s ;# } + ttk::scale .s -variable v + pack .s ; update + .s set 1 ; update +} -returnCodes 1 -match glob -result "*" + +tcltest::cleanupTests + diff --git a/tests/ttk/spinbox.test b/tests/ttk/spinbox.test new file mode 100644 index 0000000..3397e37 --- /dev/null +++ b/tests/ttk/spinbox.test @@ -0,0 +1,280 @@ +# +# ttk::spinbox widget tests +# + +package require Tk +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +test spinbox-1.0 "Spinbox tests -- setup" -body { + ttk::spinbox .sb +} -cleanup { destroy .sb } -result .sb + +test spinbox-1.1 "Bad -values list" -setup { + ttk::spinbox .sb +} -body { + .sb configure -values "bad \{list" +} -cleanup { + destroy .sb +} -returnCodes error -result "unmatched open brace in list" + +test spinbox-1.3.1 "get retrieves value" -setup { + ttk::spinbox .sb -from 0 -to 100 +} -body { + .sb set 50 + .sb get +} -cleanup { + destroy .sb +} -result 50 + +test spinbox-1.3.2 "get retrieves value" -setup { + ttk::spinbox .sb -from 0 -to 100 -values 55 +} -body { + .sb set 55 + .sb get +} -cleanup { + destroy .sb +} -result 55 + +test spinbox-1.4.1 "set changes value" -setup { + ttk::spinbox .sb -from 0 -to 100 +} -body { + .sb set 33 + .sb get +} -cleanup { + destroy .sb +} -result 33 + +test spinbox-1.4.2 "set changes value" -setup { + ttk::spinbox .sb -from 0 -to 100 -values 55 +} -body { + .sb set 33 + .sb get +} -cleanup { + destroy .sb +} -result 33 + + +test spinbox-1.6.1 "insert start" -setup { + ttk::spinbox .sb -from 0 -to 100 +} -body { + .sb set 5 + .sb insert 0 4 + .sb get +} -cleanup { + destroy .sb +} -result 45 + +test spinbox-1.6.2 "insert end" -setup { + ttk::spinbox .sb -from 0 -to 100 +} -body { + .sb set 5 + .sb insert end 4 + .sb get +} -cleanup { + destroy .sb +} -result 54 + +test spinbox-1.6.3 "insert invalid index" -setup { + ttk::spinbox .sb -from 0 -to 100 +} -body { + .sb set 5 + .sb insert 100 4 + .sb get +} -cleanup { + destroy .sb +} -result 54 + +test spinbox-1.7.1 "-command option: set doesnt fire" -setup { + ttk::spinbox .sb -from 0 -to 100 -command {set ::spinbox_test 1} +} -body { + set ::spinbox_test 0 + .sb set 50 + set ::spinbox_test +} -cleanup { + destroy .sb +} -result 0 + +test spinbox-1.7.2 "-command option: button handler will fire" -setup { + ttk::spinbox .sb -from 0 -to 100 -command {set ::spinbox_test 1} +} -body { + set ::spinbox_test 0 + .sb set 50 + event generate .sb <<Increment>> + set ::spinbox_test +} -cleanup { + destroy .sb +} -result 1 + +test spinbox-1.8.1 "option -validate" -setup { + ttk::spinbox .sb -from 0 -to 100 +} -body { + .sb configure -validate all + .sb cget -validate +} -cleanup { + destroy .sb +} -result {all} + +test spinbox-1.8.2 "option -validate" -setup { + ttk::spinbox .sb -from 0 -to 100 +} -body { + .sb configure -validate key + .sb configure -validate focus + .sb configure -validate focusin + .sb configure -validate focusout + .sb configure -validate none + .sb cget -validate +} -cleanup { + destroy .sb +} -result {none} + +test spinbox-1.8.3 "option -validate" -setup { + ttk::spinbox .sb -from 0 -to 100 +} -body { + .sb configure -validate bogus +} -cleanup { + destroy .sb +} -returnCodes error -result {bad validate "bogus": must be all, key, focus, focusin, focusout, or none} + +test spinbox-1.8.4 "-validate option: " -setup { + set ::spinbox_test {} + ttk::spinbox .sb -from 0 -to 100 +} -body { + .sb configure -validate all -validatecommand {lappend ::spinbox_test %P} + pack .sb + .sb set 50 + focus .sb + after 100 {set ::spinbox_wait 1} ; vwait ::spinbox_wait + set ::spinbox_test +} -cleanup { + destroy .sb +} -result {50} + + +test spinbox-2.0 "current command -- unset should be 0" -constraints nyi -setup { + ttk::spinbox .sb -values [list a b c d e a] +} -body { + .sb current +} -cleanup { + destroy .sb +} -result 0 +# @@@ for combobox, this is -1. + +test spinbox-2.1 "current command -- set index" -constraints nyi -setup { + ttk::spinbox .sb -values [list a b c d e a] +} -body { + .sb current 5 + .sb get +} -cleanup { + destroy .sb +} -result a + +test spinbox-2.2 "current command -- change -values" -constraints nyi -setup { + ttk::spinbox .sb -values [list a b c d e a] +} -body { + .sb current 5 + .sb configure -values [list c b a d e] + .sb current +} -cleanup { + destroy .sb +} -result 2 + +test spinbox-2.3 "current command -- change value" -constraints nyi -setup { + ttk::spinbox .sb -values [list c b a d e] +} -body { + .sb current 2 + .sb set "b" + .sb current +} -cleanup { + destroy .sb +} -result 1 + +test spinbox-2.4 "current command -- value not in list" -constraints nyi -setup { + ttk::spinbox .sb -values [list c b a d e] +} -body { + .sb current 2 + .sb set "z" + .sb current +} -cleanup { + destroy .sb +} -result -1 + +# nostomp: NB intentional difference between ttk::spinbox and tk::spinbox; +# see also #1439266 +# +test spinbox-nostomp-1 "don't stomp on -variable (init; -from/to)" -body { + set SBV 55 + ttk::spinbox .sb -textvariable SBV -from 0 -to 100 -increment 5 + list $SBV [.sb get] +} -cleanup { + unset SBV + destroy .sb +} -result [list 55 55] + +test spinbox-nostomp-2 "don't stomp on -variable (init; -values)" -body { + set SBV Apr + ttk::spinbox .sb -textvariable SBV -values {Jan Feb Mar Apr May Jun Jul Aug} + list $SBV [.sb get] +} -cleanup { + unset SBV + destroy .sb +} -result [list Apr Apr] + +test spinbox-nostomp-3 "don't stomp on -variable (configure; -from/to)" -body { + set SBV 55 + ttk::spinbox .sb + .sb configure -textvariable SBV -from 0 -to 100 -increment 5 + list $SBV [.sb get] +} -cleanup { + unset SBV + destroy .sb +} -result [list 55 55] + +test spinbox-nostomp-4 "don't stomp on -variable (configure; -values)" -body { + set SBV Apr + ttk::spinbox .sb + .sb configure -textvariable SBV -values {Jan Feb Mar Apr May Jun Jul Aug} + list $SBV [.sb get] +} -cleanup { + unset SBV + destroy .sb +} -result [list Apr Apr] + +test spinbox-dieoctaldie-1 "Cope with leading zeros" -body { + # See SF#2358545 -- ttk::spinbox also affected + set secs 07 + ttk::spinbox .sb -from 0 -to 59 -format %02.0f -textvariable secs + + set result [list $secs] + event generate .sb <<Increment>>; lappend result $secs + event generate .sb <<Increment>>; lappend result $secs + event generate .sb <<Increment>>; lappend result $secs + event generate .sb <<Increment>>; lappend result $secs + + event generate .sb <<Decrement>>; lappend result $secs + event generate .sb <<Decrement>>; lappend result $secs + event generate .sb <<Decrement>>; lappend result $secs + event generate .sb <<Decrement>>; lappend result $secs + + set result +} -result [list 07 08 09 10 11 10 09 08 07] -cleanup { + destroy .sb + unset secs +} + +test spinbox-dieoctaldie-2 "Cope with general bad input" -body { + set result [list] + ttk::spinbox .sb -from 0 -to 100 -format %03.0f + .sb set asdfasdf ; lappend result [.sb get] + event generate .sb <<Increment>> ; lappend result [.sb get] + .sb set asdfasdf ; lappend result [.sb get] + event generate .sb <<Decrement>> ; lappend result [.sb get] +} -result [list asdfasdf 000 asdfasdf 000] -cleanup { + destroy .sb +} + +tcltest::cleanupTests + +# Local variables: +# mode: tcl +# End: diff --git a/tests/ttk/treetags.test b/tests/ttk/treetags.test new file mode 100644 index 0000000..7f26e2f --- /dev/null +++ b/tests/ttk/treetags.test @@ -0,0 +1,221 @@ + +package require Tk +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +### treeview tag invariants: +# + +proc assert {expr {message ""}} { + if {![uplevel 1 [list expr $expr]]} { + error "PANIC: $message ($expr failed)" + } +} +proc in {e l} { expr {[lsearch -exact $l $e] >= 0} } + +proc itemConstraints {tv item} { + # $tag in [$tv item $item -tags] <==> [$tv tag has $tag $item] + foreach tag [$tv item $item -tags] { + assert {[in $item [$tv tag has $tag]]} + } + foreach child [$tv children $item] { + itemConstraints $tv $child + } +} + +proc treeConstraints {tv} { + # $item in [$tv tag has $tag] <==> [$tv tag has $tag $item] + # + foreach tag [$tv tag names] { + foreach item [$tv tag has $tag] { + assert {[in $tag [$tv item $item -tags]]} + } + } + + itemConstraints $tv {} +} +# +### + +test treetags-1.0 "Setup" -body { + set tv [ttk::treeview .tv] + .tv insert {} end -id item1 -text "Item 1" + pack .tv +} -cleanup { + treeConstraints $tv +} + +test treetags-1.1 "Bad tag list" -body { + $tv item item1 -tags {bad {list}here bad} + $tv item item1 -tags +} -returnCodes error -result "list element in braces *" -match glob + +test treetags-1.2 "Good tag list" -body { + $tv item item1 -tags tag1 + $tv item item1 -tags +} -cleanup { + assert {[$tv tag has tag1 item1]} + treeConstraints $tv +} -result [list tag1] + +test treetags-1.3 "tag has - test" -body { + $tv insert {} end -id item2 -text "Item 2" -tags tag2 + set result [list] + foreach item {item1 item2} { + foreach tag {tag1 tag2 tag3} { + lappend result $item $tag [$tv tag has $tag $item] + } + } + set result +} -cleanup { + treeConstraints $tv +} -result [list \ + item1 tag1 1 item1 tag2 0 item1 tag3 0 \ + item2 tag1 0 item2 tag2 1 item2 tag3 0 ] + +test treetags-1.4 "tag has - query" -body { + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list item1] [list item2] [list]] + +test treetags-1.5 "tag add" -body { + $tv tag add tag3 {item1 item2} + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list item1] [list item2] [list item1 item2]] + +test treetags-1.6 "tag remove - list" -body { + $tv tag remove tag3 {item1 item2} + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list item1] [list item2] [list]] + +test treetags-1.7 "tag remove - all items" -body { + $tv tag remove tag1 + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list] [list item2] [list]] + +test treetags-1.8 "tag names" -body { + lsort [$tv tag names] +} -result [list tag1 tag2 tag3] + +test treetags-1.9 "tag names - tag added to item" -body { + $tv item item1 -tags tag4 + lsort [$tv tag names] +} -result [list tag1 tag2 tag3 tag4] + +test treetags-1.10 "tag names - tag configured" -body { + $tv tag configure tag5 + lsort [$tv tag names] +} -result [list tag1 tag2 tag3 tag4 tag5] + +test treetags-1.end "cleanup" -body { + $tv item item1 -tags tag1 + $tv item item2 -tags tag2 + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list item1] [list item2] [list]] + +test treetags-2.0 "tag bind" -body { + $tv tag bind tag1 <KeyPress> {set ::KEY %A} + $tv tag bind tag1 <KeyPress> +} -cleanup { + treeConstraints $tv +} -result {set ::KEY %A} + +test treetags-2.1 "Events delivered to tags" -body { + focus -force $tv ; update ;# needed so [event generate] delivers KeyPress + $tv focus item1 + event generate $tv <KeyPress-a> + set ::KEY +} -cleanup { + treeConstraints $tv +} -result a + +test treetags-2.2 "Events delivered to correct tags" -body { + $tv tag bind tag2 <KeyPress> [list set ::KEY2 %A] + + $tv focus item1 + event generate $tv <KeyPress-b> + $tv focus item2 + event generate $tv <KeyPress-c> + + list $::KEY $::KEY2 +} -cleanup { + treeConstraints $tv +} -result [list b c] + +test treetags-2.3 "Virtual events delivered to focus item" -body { + set ::bong 0 + $tv tag bind tag2 <<Bing>> { incr bong } + $tv focus item2 + event generate $tv <<Bing>> + $tv focus item1 + event generate $tv <<Bing>> + set bong +} -cleanup { + treeConstraints $tv +} -result 1 + +test treetags-2.4 "Bad events" -body { + $tv tag bind bad <Enter> { puts "Entered!" } +} -returnCodes 1 -result "unsupported event <Enter>*" -match glob + +test treetags-3.0 "tag configure - set" -body { + $tv tag configure tag1 -foreground blue -background red +} -cleanup { + treeConstraints $tv +} -result {} + +test treetags-3.1 "tag configure - get" -body { + $tv tag configure tag1 -foreground +} -cleanup { + treeConstraints $tv +} -result blue + +# @@@ fragile test +test treetags-3.2 "tag configure - enumerate" -body { + $tv tag configure tag1 +} -cleanup { + treeConstraints $tv +} -result [list \ + -text {} -image {} -anchor {} -background red -foreground blue -font {} \ +] + +# The next test exercises tag resource management. +# If options are not properly freed, the message: +# Test file error: "Font times 20 still in cache." +# will show up on stderr at program exit. +# +test treetags-3.3 "tag configure - set font" -body { + $tv tag configure tag2 -font {times 20} +} + +test treetags-3.4 "stomp tags in tag binding procedure" -body { + set result [list] + $tv tag bind rm1 <<Remove>> { lappend ::result rm1 [%W focus] <<Remove>> } + $tv tag bind rm2 <<Remove>> { + lappend ::result rm2 [%W focus] <<Remove>> + %W item [%W focus] -tags {tag1} + } + $tv tag bind rm3 <<Remove>> { lappend ::result rm3 [%W focus] <<Remove>> } + + $tv item item1 -tags {rm1 rm2 rm3} + $tv focus item1 + event generate $tv <<Remove>> + set result +} -cleanup { + treeConstraints $tv +} -result [list rm1 item1 <<Remove>> rm2 item1 <<Remove>> rm3 item1 <<Remove>>] + +# + +test treetags-end "Cleanup" -body { destroy $tv } + +tcltest::cleanupTests diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test new file mode 100644 index 0000000..d8bc65d --- /dev/null +++ b/tests/ttk/treeview.test @@ -0,0 +1,639 @@ +# +# [7Jun2005] TO CHECK: [$tv see {}] -- shouldn't work (at least, shouldn't do +# what it currently does) +# + +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +# consistencyCheck -- +# Traverse the tree to make sure the item data structures +# are properly linked. +# +# Since [$tv children] follows ->next links and [$tv index] +# follows ->prev links, this should cover all invariants. +# +proc consistencyCheck {tv {item {}}} { + set i 0; + foreach child [$tv children $item] { + assert {[$tv parent $child] == $item} "parent $child = $item" + assert {[$tv index $child] == $i} "index $child [$tv index $child]=$i" + incr i + consistencyCheck $tv $child + } +} + +proc assert {expr {message ""}} { + if {![uplevel 1 [list expr $expr]]} { + set error "PANIC! PANIC! PANIC: $message ($expr failed)" + puts stderr $error + error $error + } +} + +test treeview-0 "treeview test - setup" -body { + ttk::treeview .tv -columns {a b c} + pack .tv -expand true -fill both + update +} + +test treeview-1.1 "columns" -body { + .tv configure -columns {a b c} +} + +test treeview-1.2 "Bad columns" -body { + #.tv configure -columns {illegal "list"value} + ttk::treeview .badtv -columns {illegal "list"value} +} -returnCodes 1 -result "list element in quotes followed by*" -match glob + +test treeview-1.3 "bad displaycolumns" -body { + .tv configure -displaycolumns {a b d} +} -returnCodes 1 -result "Invalid column index d" + +test treeview-1.4 "more bad displaycolumns" -body { + .tv configure -displaycolumns {1 2 3} +} -returnCodes 1 -result "Column index 3 out of bounds" + +test treeview-1.5 "Don't forget to check negative numbers" -body { + .tv configure -displaycolumns {1 -2 3} +} -returnCodes 1 -result "Column index -2 out of bounds" + +# Item creation. +# +test treeview-2.1 "insert -- not enough args" -body { + .tv insert +} -returnCodes 1 -result "wrong # args: *" -match glob + +test treeview-2.3 "insert -- bad integer index" -body { + .tv insert {} badindex +} -returnCodes 1 -result "expected integer *" -match glob + +test treeview-2.4 "insert -- bad parent node" -body { + .tv insert badparent end +} -returnCodes 1 -result "Item badparent not found" -match glob + +test treeview-2.5 "insert -- finaly insert a node" -body { + .tv insert {} end -id newnode -text "New node" +} -result newnode + +test treeview-2.6 "insert -- make sure node was inserted" -body { + .tv children {} +} -result [list newnode] + +test treeview-2.7 "insert -- prevent duplicate node names" -body { + .tv insert {} end -id newnode +} -returnCodes 1 -result "Item newnode already exists" + +test treeview-2.8 "insert -- new node at end" -body { + .tv insert {} end -id lastnode + consistencyCheck .tv + .tv children {} +} -result [list newnode lastnode] + +consistencyCheck .tv + +test treeview-2.9 "insert -- new node at beginning" -body { + .tv insert {} 0 -id firstnode + consistencyCheck .tv + .tv children {} +} -result [list firstnode newnode lastnode] + +test treeview-2.10 "insert -- one more node" -body { + .tv insert {} 2 -id onemore + consistencyCheck .tv + .tv children {} +} -result [list firstnode newnode onemore lastnode] + +test treeview-2.11 "insert -- and another one" -body { + .tv insert {} 2 -id anotherone + consistencyCheck .tv + .tv children {} +} -result [list firstnode newnode anotherone onemore lastnode] + +test treeview-2.12 "insert -- one more at end" -body { + .tv insert {} end -id newlastone + consistencyCheck .tv + .tv children {} +} -result [list firstnode newnode anotherone onemore lastnode newlastone] + +test treeview-2.13 "insert -- one more at beginning" -body { + .tv insert {} 0 -id newfirstone + consistencyCheck .tv + .tv children {} +} -result [list newfirstone firstnode newnode anotherone onemore lastnode newlastone] + +test treeview-2.14 "insert -- bad options" -body { + .tv insert {} end -badoption foo +} -returnCodes 1 -result {unknown option "-badoption"} + +test treeview-2.15 "insert -- at position 0 w/no children" -body { + .tv insert newnode 0 -id newnode.n2 -text "Foo" + .tv children newnode +} -result newnode.n2 ;# don't crash + +test treeview-2.16 "insert -- insert way past end" -body { + .tv insert newnode 99 -id newnode.n3 -text "Foo" + consistencyCheck .tv + .tv children newnode +} -result [list newnode.n2 newnode.n3] + +test treeview-2.17 "insert -- insert before beginning" -body { + .tv insert newnode -1 -id newnode.n1 -text "Foo" + consistencyCheck .tv + .tv children newnode +} -result [list newnode.n1 newnode.n2 newnode.n3] + +### +# +test treeview-3.1 "parent" -body { + .tv parent newnode.n1 +} -result newnode +test treeview-3.2 "parent - top-level node" -body { + .tv parent newnode +} -result {} +test treeview-3.3 "parent - root node" -body { + .tv parent {} +} -result {} +test treeview-3.4 "index" -body { + list [.tv index newnode.n3] [.tv index newnode.n2] [.tv index newnode.n1] +} -result [list 2 1 0] +test treeview-3.5 "index - exhaustive test" -body { + set result [list] + foreach item [.tv children {}] { + lappend result [.tv index $item] + } + set result +} -result [list 0 1 2 3 4 5 6] + +test treeview-3.6 "detach" -body { + .tv detach newnode + consistencyCheck .tv + .tv children {} +} -result [list newfirstone firstnode anotherone onemore lastnode newlastone] +# XREF: treeview-2.13 + +test treeview-3.7 "detach didn't screw up internal links" -body { + consistencyCheck .tv + set result [list] + foreach item [.tv children {}] { + lappend result [.tv index $item] + } + set result +} -result [list 0 1 2 3 4 5] + +test treeview-3.8 "detached node has no parent, index 0" -body { + list [.tv parent newnode] [.tv index newnode] +} -result [list {} 0] +# @@@ Can't distinguish detached nodes from first root node + +test treeview-3.9 "detached node's children undisturbed" -body { + .tv children newnode +} -result [list newnode.n1 newnode.n2 newnode.n3] + +test treeview-3.10 "detach is idempotent" -body { + .tv detach newnode + consistencyCheck .tv + .tv children {} +} -result [list newfirstone firstnode anotherone onemore lastnode newlastone] + +test treeview-3.11 "Can't detach root item" -body { + .tv detach [list {}] + update + consistencyCheck .tv +} -returnCodes 1 -result "Cannot detach root item" +consistencyCheck .tv + +test treeview-3.12 "Reattach" -body { + .tv move newnode {} end + consistencyCheck .tv + .tv children {} +} -result [list newfirstone firstnode anotherone onemore lastnode newlastone newnode] + +# Bug # ????? +test treeview-3.13 "Re-reattach" -body { + .tv move newnode {} end + consistencyCheck .tv + .tv children {} +} -result [list newfirstone firstnode anotherone onemore lastnode newlastone newnode] + +catch { + .tv insert newfirstone end -id x1 + .tv insert newfirstone end -id x2 + .tv insert newfirstone end -id x3 +} + +test treeview-3.14 "Duplicated entry in children list" -body { + .tv children newfirstone [list x3 x1 x2 x3] + # ??? Maybe this should raise an error? + consistencyCheck .tv + .tv children newfirstone +} -result [list x3 x1 x2] + +test treeview-3.14.1 "Duplicated entry in children list" -body { + .tv children newfirstone [list x1 x2 x3 x3 x2 x1] + consistencyCheck .tv + .tv children newfirstone +} -result [list x1 x2 x3] + +test treeview-3.15 "Consecutive duplicate entries in children list" -body { + .tv children newfirstone [list x1 x2 x2 x3] + consistencyCheck .tv + .tv children newfirstone +} -result [list x1 x2 x3] + +test treeview-3.16 "Insert child after self" -body { + .tv move x2 newfirstone 1 + consistencyCheck .tv + .tv children newfirstone +} -result [list x1 x2 x3] + +test treeview-3.17 "Insert last child after self" -body { + .tv move x3 newfirstone 2 + consistencyCheck .tv + .tv children newfirstone +} -result [list x1 x2 x3] + +test treeview-3.18 "Insert last child after end" -body { + .tv move x3 newfirstone 3 + consistencyCheck .tv + .tv children newfirstone +} -result [list x1 x2 x3] + +test treeview-4.1 "opened - initial state" -body { + .tv item newnode -open +} -result 0 +test treeview-4.2 "opened - open node" -body { + .tv item newnode -open 1 + .tv item newnode -open +} -result 1 +test treeview-4.3 "opened - closed node" -body { + .tv item newnode -open 0 + .tv item newnode -open +} -result 0 + +test treeview-5.1 "item -- error checks" -body { + .tv item newnode -text "Bad values" -values "{bad}list" +} -returnCodes 1 -result "list element in braces followed by*" -match glob + +test treeview-5.2 "item -- error leaves options unchanged " -body { + .tv item newnode -text +} -result "New node" + +test treeview-5.3 "Heading" -body { + .tv heading #0 -text "Heading" +} + +test treeview-5.4 "get cell" -body { + set l [list a b c] + .tv item newnode -values $l + .tv set newnode 1 +} -result b + +test treeview-5.5 "set cell" -body { + .tv set newnode 1 XXX + .tv item newnode -values +} -result [list a XXX c] + +test treeview-5.6 "set illegal cell" -body { + .tv set newnode #0 YYY +} -returnCodes 1 -result "Display column #0 cannot be set" + +test treeview-5.7 "set illegal cell" -body { + .tv set newnode 3 YY ;# 3 == current #columns +} -returnCodes 1 -result "Column index 3 out of bounds" + +test treeview-5.8 "set display columns" -body { + .tv configure -displaycolumns [list 2 1 0] + .tv set newnode #1 X + .tv set newnode #2 Y + .tv set newnode #3 Z + .tv item newnode -values +} -result [list Z Y X] + +test treeview-5.9 "display columns part 2" -body { + list [.tv column #1 -id] [.tv column #2 -id] [.tv column #3 -id] +} -result [list c b a] + +test treeview-5.10 "cannot set column -id" -body { + .tv column #1 -id X +} -returnCodes 1 -result "Attempt to change read-only option" + +test treeview-5.11 "get" -body { + .tv set newnode #1 +} -result X + +test treeview-5.12 "get dictionary" -body { + .tv set newnode +} -result [list a Z b Y c X] + +test treeview-5.13 "get, no value" -body { + set newitem [.tv insert {} end] + set result [.tv set $newitem #1] + .tv delete $newitem + set result +} -result {} + + +test treeview-6.1 "deletion - setup" -body { + .tv insert {} end -id dtest + foreach id [list a b c d e] { + .tv insert dtest end -id $id + } + .tv children dtest +} -result [list a b c d e] + +test treeview-6.1.1 "delete" -body { + .tv delete b + consistencyCheck .tv + list [.tv exists b] [.tv children dtest] +} -result [list 0 [list a c d e]] + +consistencyCheck .tv + +test treeview-6.2 "delete - duplicate items in list" -body { + .tv delete [list a e a e] + consistencyCheck .tv + .tv children dtest +} -result [list c d] + +test treeview-6.3 "delete - descendants removed" -body { + .tv insert c end -id c1 + .tv insert c end -id c2 + .tv insert c1 end -id c11 + consistencyCheck .tv + .tv delete c + consistencyCheck .tv + list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11] +} -result [list 0 0 0 0] + +test treeview-6.4 "delete - delete parent and descendants" -body { + .tv insert dtest end -id c + .tv insert c end -id c1 + .tv insert c end -id c2 + .tv insert c1 end -id c11 + consistencyCheck .tv + .tv delete [list c c1 c2 c11] + consistencyCheck .tv + list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11] +} -result [list 0 0 0 0] + +test treeview-6.5 "delete - delete descendants and parent" -body { + .tv insert dtest end -id c + .tv insert c end -id c1 + .tv insert c end -id c2 + .tv insert c1 end -id c11 + consistencyCheck .tv + .tv delete [list c11 c1 c2 c] + consistencyCheck .tv + list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11] +} -result [list 0 0 0 0] + +test treeview-6.6 "delete - end" -body { + consistencyCheck .tv + .tv children dtest +} -result [list d] + +test treeview-7.1 "move" -body { + .tv insert d end -id d1 + .tv insert d end -id d2 + .tv insert d end -id d3 + .tv move d3 d 0 + consistencyCheck .tv + .tv children d +} -result [list d3 d1 d2] + +test treeview-7.2 "illegal move" -body { + .tv move d d2 end +} -returnCodes 1 -result "Cannot insert d as a descendant of d2" + +test treeview-7.3 "illegal move has no effect" -body { + consistencyCheck .tv + .tv children d +} -result [list d3 d1 d2] + +test treeview-7.4 "Replace children" -body { + .tv children d [list d3 d2 d1] + consistencyCheck .tv + .tv children d +} -result [list d3 d2 d1] + +test treeview-7.5 "replace children - precondition" -body { + # Just check to make sure the test suite so far has left + # us in the state we expect to be in: + list [.tv parent newnode] [.tv children newnode] +} -result [list {} [list newnode.n1 newnode.n2 newnode.n3]] + +test treeview-7.6 "Replace children - illegal move" -body { + .tv children newnode.n1 [list newnode.n1 newnode.n2 newnode.n3] +} -returnCodes 1 -result "Cannot insert newnode.n1 as a descendant of newnode.n1" + +consistencyCheck .tv + +test treeview-8.0 "Selection set" -body { + .tv selection set [list newnode.n1 newnode.n3 newnode.n2] + .tv selection +} -result [list newnode.n1 newnode.n2 newnode.n3] + +test treeview-8.1 "Selection add" -body { + .tv selection add [list newnode] + .tv selection +} -result [list newnode newnode.n1 newnode.n2 newnode.n3] + +test treeview-8.2 "Selection toggle" -body { + .tv selection toggle [list newnode.n2 d3] + .tv selection +} -result [list newnode newnode.n1 newnode.n3 d3] + +test treeview-8.3 "Selection remove" -body { + .tv selection remove [list newnode.n2 d3] + .tv selection +} -result [list newnode newnode.n1 newnode.n3] + +test treeview-8.4 "Selection - clear" -body { + .tv selection set {} + .tv selection +} -result {} + +test treeview-8.5 "Selection - bad operation" -body { + .tv selection badop foo +} -returnCodes 1 -match glob -result {bad selection operation "badop": must be *} + +### NEED: more tests for see/yview/scrolling + +proc scrollcallback {args} { + set ::scrolldata $args +} +test treeview-9.0 "scroll callback - empty tree" -body { + .tv configure -yscrollcommand scrollcallback + .tv delete [.tv children {}] + update + set ::scrolldata +} -result [list 0.0 1.0] + +### identify tests: +# +proc identify* {tv comps args} { + foreach {x y} $args { + foreach comp $comps { + lappend result [$tv identify $comp $x $y] + } + } + return $result +} + +# get list of column IDs from list of display column ids. +# +proc columnids {tv dcols} { + set result [list] + foreach dcol $dcols { + if {[catch { + lappend result [$tv column $dcol -id] + }]} { + lappend result ERROR + } + } + return $result +} + +test treeview-identify-setup "identify series - setup" -body { + destroy .tv + ttk::setTheme default + ttk::treeview .tv -columns [list A B C] + .tv insert {} end -id branch -text branch -open true + .tv insert branch end -id item1 -text item1 + .tv insert branch end -id item2 -text item2 + .tv insert branch end -id item3 -text item3 + + .tv column #0 -width 50 ;# 0-50 + .tv column A -width 50 ;# 50-100 + .tv column B -width 50 ;# 100-150 + .tv column C -width 50 ;# 150-200 (plus slop for margins) + + wm geometry . {} ; pack .tv ; update +} + +test treeview-identify-1 "identify heading" -body { + .tv configure -show {headings tree} + update idletasks + identify* .tv {region column} 10 10 +} -result [list heading #0] + +test treeview-identify-2 "identify columns" -body { + .tv configure -displaycolumns #all + update idletasks + columnids .tv [identify* .tv column 25 10 75 10 125 10 175 10] +} -result [list {} A B C] + +test treeview-identify-3 "reordered columns" -body { + .tv configure -displaycolumns {B A C} + update idletasks + columnids .tv [identify* .tv column 25 10 75 10 125 10 175 10] +} -result [list {} B A C] + +test treeview-identify-4 "no tree column" -body { + .tv configure -displaycolumns #all -show {headings} + update idletasks + identify* .tv {region column} 25 10 75 10 125 10 175 10 +} -result [list heading #1 heading #2 heading #3 nothing {}] + +# Item height in default theme is 20px +test treeview-identify-5 "vertical scan - no headings" -body { + .tv configure -displaycolumns #all -show {tree} + update idletasks + identify* .tv {region item} 25 10 25 30 25 50 25 70 25 90 +} -result [list tree branch tree item1 tree item2 tree item3 nothing {}] + +test treeview-identify-6 "vertical scan - with headings" -body { + .tv configure -displaycolumns #all -show {tree headings} + update idletasks + identify* .tv {region item} 25 10 25 30 25 50 25 70 25 90 +} -result [list heading {} tree branch tree item1 tree item2 tree item3] + +test treeview-identify-7 "vertical scan - headings, no tree" -body { + .tv configure -displaycolumns #all -show {headings} + update idletasks + identify* .tv {region item} 25 10 25 30 25 50 25 70 25 90 +} -result [list heading {} cell branch cell item1 cell item2 cell item3] + +# In default theme, -indent and -itemheight both 20px +# Disclosure element name is "Treeitem.indicator" +set disclosure "*.indicator" +test treeview-identify-8 "identify element" -body { + .tv configure -show {tree} + .tv insert branch 0 -id branch2 -open true + .tv insert branch2 0 -id branch3 -open true + .tv insert branch3 0 -id leaf3 + update idletasks; + identify* .tv {item element} 10 10 30 30 50 50 +} -match glob -result [list \ + branch $disclosure branch2 $disclosure branch3 $disclosure] + +# See #2381555 +test treeview-identify-9 "identify works when horizontally scrolled" -setup { + .tv configure -show {tree headings} + foreach column {#0 A B C} { + .tv column $column -stretch 0 -width 50 + } + place .tv -x 0 -y 0 -width 100 +} -body { + set result [list] + foreach xoffs {0 50 100} { + .tv xview $xoffs ; update + lappend result [identify* .tv {region column} 10 10 60 10] + } + set result +} -result [list \ + [list heading #0 heading #1] \ + [list heading #1 heading #2] \ + [list heading #2 heading #3] ] + +test treeview-identify-cleanup "identify - cleanup" -body { + destroy .tv +} + +### NEED: tests for focus item, selection + +### Misc. tests: + +destroy .tv +test treeview-10.1 "Root node properly initialized (#1541739)" -setup { + ttk::treeview .tv + .tv insert {} end -id a + .tv see a +} -cleanup { + destroy .tv +} + +test treeview-3006842 "Null bindings" -setup { + ttk::treeview .tv -show tree +} -body { + .tv tag bind empty <ButtonPress-1> {} + .tv insert {} end -text "Click me" -tags empty + event generate .tv <ButtonPress-1> -x 10 -y 10 + .tv tag bind empty +} -result {} -cleanup { + destroy .tv +} + +test treeview-3085489-1 "tag add, no -tags" -setup { + ttk::treeview .tv +} -body { + set item [.tv insert {} end] + .tv tag add foo $item + .tv item $item -tags +} -cleanup { + destroy .tv +} -result [list foo] + +test treeview-3085489-2 "tag remove, no -tags" -setup { + ttk::treeview .tv +} -body { + set item [.tv insert {} end] + .tv tag remove foo $item + .tv item $item -tags +} -cleanup { + destroy .tv +} -result [list] + +tcltest::cleanupTests diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test new file mode 100644 index 0000000..ddfaf84 --- /dev/null +++ b/tests/ttk/ttk.test @@ -0,0 +1,604 @@ + +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +proc skip args {} +proc ok {} { return } + +proc bgerror {error} { + variable bgerror $error + variable bgerrorInfo $::errorInfo + variable bgerrorCode $::errorCode +} + +# Self-destruct tests. +# Do these early, so any memory corruption has a longer time to cause a crash. +# +proc selfdestruct {w args} { + destroy $w +} +test ttk-6.1 "Self-destructing checkbutton" -body { + pack [ttk::checkbutton .sd -text "Self-destruction" -variable ::sd] + trace variable sd w [list selfdestruct .sd] + update + .sd invoke +} -returnCodes 1 +test ttk-6.2 "Checkbutton self-destructed" -body { + winfo exists .sd +} -result 0 + +# test ttk-6.3 not applicable [see #2175411] + +test ttk-6.4 "Destroy widget in configure" -setup { + set OUCH ouch + trace variable OUCH r { kill.b } + proc kill.b {args} { destroy .b } +} -cleanup { + unset OUCH +} -body { + pack [ttk::checkbutton .b] + set rc [catch { .b configure -variable OUCH } msg] + list $rc $msg [winfo exists .b] [info commands .b] +} -result [list 1 "Widget has been destroyed" 0 {}] + +test ttk-6.5 "Clean up -textvariable traces" -body { + foreach class {ttk::button ttk::checkbutton ttk::radiobutton} { + $class .b1 -textvariable V + set V "asdf" + destroy .b1 + set V "" + } +} + +test ttk-6.6 "Bad color spec in styles" -body { + pack [ttk::button .b1 -text Hi!] + ttk::style configure TButton -foreground badColor + event generate .b1 <Expose> + update + ttk::style configure TButton -foreground black + destroy .b1 + set ::bgerror +} -result {unknown color name "badColor"} + +test ttk-6.7 "Basic destruction test" -body { + foreach widget { + button checkbutton radiobutton sizegrip separator notebook + progressbar panedwindow scrollbar + } { + ttk::$widget .w + pack .w + destroy .w + } +} + +test ttk-6.8 "Button command removes itself" -body { + ttk::button .b -command ".b configure -command {}; set ::A {it worked}" + .b invoke + destroy .b + set ::A +} -result {it worked} + +test ttk-6.9 "Bad font spec in styles" -setup { + ttk::style theme create badfont -settings { + ttk::style configure . -font {Helvetica 12 Bogus} + } + ttk::style theme use badfont +} -cleanup { + ttk::style theme use default +} -body { + pack [ttk::label .l -text Hi! -font {}] + event generate .l <Expose> + update + destroy .l + set ::bgerror +} -result {unknown font style "Bogus"} + +test ttk-construction-failure-1 "Excercise construction failure path" -setup { + option add *TLabel.cursor badCursor 1 +} -cleanup { + option add *TLabel.cursor {} 1 +} -body { + catch {ttk::label .l} errmsg + list $errmsg [info commands .l] [winfo exists .l] +} -result [list {bad cursor spec "badCursor"} {} 0] + +test ttk-construction-failure-2 "Destroy widget in constructor" -setup { + set OUCH ouch + trace variable OUCH r { kill.b } + proc kill.b {args} { destroy .b } +} -cleanup { + unset OUCH +} -body { + list \ + [catch { ttk::checkbutton .b -variable OUCH } msg] \ + $msg \ + [winfo exists .b] \ + [info commands .b] \ + ; +} -result [list 1 "Widget has been destroyed" 0 {}] + +test ttk-selfdestruct-ok-1 "Intentional self-destruction" -body { + # see #2298720 + toplevel .t + ttk::button .t.b -command [list destroy .t] + .t.b invoke + list [winfo exists .t] [winfo exists .t.b] +} -result [list 0 0] + +# +# Basic tests. +# +test ttk-1.1 "Create button" -body { + pack [ttk::button .t] -expand true -fill both + update +} + +test ttk-1.2 "Check style" -body { + .t cget -style +} -result {} + +test ttk-1.3 "Set bad style" -body { + .t configure -style "nosuchstyle" +} -returnCodes 1 -result {Layout nosuchstyle not found} + +test ttk-1.4 "Original style preserved" -body { + .t cget -style +} -result "" + +proc checkstate {w} { + foreach statespec { + {!active !disabled} + {!active disabled} + {active !disabled} + {active disabled} + active + disabled + } { + lappend result [$w instate $statespec] + } + set result +} + +# NB: this will fail if the top-level window pops up underneath the cursor +test ttk-2.0 "Check state" -body { + checkstate .t +} -result [list 1 0 0 0 0 0] + +test ttk-2.1 "Change state" -body { + .t state active +} -result !active + +test ttk-2.2 "Check state again" -body { + checkstate .t +} -result [list 0 0 1 0 1 0] + +test ttk-2.3 "Change state again" -body { + .t state {!active disabled} +} -result {active !disabled} + +test ttk-2.4 "Check state again" -body { + checkstate .t +} -result [list 0 1 0 0 0 1] + +test ttk-2.5 "Change state again" -body { + .t state !disabled +} -result {disabled} + +test ttk-2.6 "instate scripts, false" -body { + set x 0 + .t instate disabled { set x 1 } + set x +} -result 0 + +test ttk-2.7 "instate scripts, true" -body { + set x 0 + .t instate !disabled { set x 1 } + set x +} -result 1 + +test ttk-2.8 "bug 3223850: button state disabled during click" -setup { + destroy .b + set ttk28 {} + pack [ttk::button .b -command {set ::ttk28 failed}] +} -body { + bind .b <ButtonPress-1> {after 0 {.b configure -state disabled}} + after 1 {event generate .b <ButtonPress-1>} + after 20 {event generate .b <ButtonRelease-1>} + set aid [after 100 {set ::ttk28 [.b instate {disabled !pressed}]}] + vwait ::ttk28 + after cancel $aid + set ttk28 +} -cleanup { + destroy .b + unset -nocomplain ttk28 aid +} -result 1 + +# misc. error detection +test ttk-3.0 "Bad option" -body { + ttk::button .bad -badoption foo +} -returnCodes 1 -result {unknown option "-badoption"} -match glob + +test ttk-3.1 "Make sure widget command not created" -body { + .bad state disabled +} -returnCodes 1 -result {invalid command name ".bad"} -match glob + +test ttk-3.2 "Propagate errors from variable traces" -body { + set A 0 + trace add variable A write {error "failure" ;# } + ttk::checkbutton .cb -variable A + .cb invoke +} -cleanup { + unset ::A ; destroy .cb +} -returnCodes error -result {can't set "A": failure} + +test ttk-3.3 "Constructor failure with cursor" -body { + ttk::button .b -cursor bottom_right_corner -style BadStyle +} -returnCodes 1 -result "Layout BadStyle not found" + +test ttk-3.4 "SF#2009213" -body { + ttk::style configure TScale -sliderrelief {} + pack [ttk::scale .s] + update +} -cleanup { + ttk::style configure TScale -sliderrelief raised + destroy .s +} + +# Test resource allocation +# (@@@ "-font" is a compatibility option now, so tests 4.1-4.3 +# don't really test anything useful at the moment.) +# + +test ttk-4.0 "Setup" -body { + catch { destroy .t } + pack [ttk::label .t -text "Button 1"] + testConstraint fontOption [expr ![catch { set prevFont [.t cget -font] }]] + ok +} + +test ttk-4.1 "Change font" -constraints fontOption -body { + .t configure -font "Helvetica 18 bold" +} +test ttk-4.2 "Check font" -constraints fontOption -body { + .t cget -font +} -result "Helvetica 18 bold" + +test ttk-4.3 "Restore font" -constraints fontOption -body { + .t configure -font $prevFont +} + +test ttk-4.4 "Bad resource specifications" -body { + ttk::style theme settings alt { + ttk::style configure TButton -font {Bad font} + # @@@ it would be best to raise an error at this point, + # @@@ but that's not really feasible in the current framework. + } + pack [ttk::button .tb1 -text "Ouch"] + ttk::style theme use alt + update; + # As long as we haven't crashed, everything's OK + ttk::style theme settings alt { + ttk::style configure TButton -font TkDefaultFont + } + ttk::style theme use default + destroy .tb1 +} + +# +# -compound tests: +# +variable iconData \ +{R0lGODlhIAAgAKIAANnZ2YQAAP8AAISEhP///////////////yH5BAEAAAAALAAAAAAgACAA +AAP/CLoMGLqKoMvtGIqiqxEYCLrcioGiyxwIusyBgaLLLRiBoMsQKLrcjYGgu4Giy+2CAkFX +A0WX2wXFIOgGii7trkCEohsDCACBoktEKLpKhISiGwAIECiqSKooukiqKKoxgACBooukKiIo +SKooujGDECi6iqQqsopEV2MQAkV3kXQZRXdjEAJFl5F0FUWXY3ACRZcFSRdFlyVwJlB0WZB0 +UXRZAmcCRZeRdBVFl2NwAkV3kXQZRXdjcAJFV5FURVaR6GoMDgSKLpKqiKAgqaLoxgwOBIoq +kiqKLpIqimrM4ECg6BIRiq4SIaHoxgyCBoou7a5AhKIbMzgAAIGiy+2CTWJmBhAAAkWX2wXF +zCDoBooud2PMDIKuRqDocgtGzMwg6O4Eii5z4Kgi6DIMhqLoagQGjiqCLvPgYOgqji6CLrfi +6DIj6HI7jq4i6DIkADs=} + +variable compoundStrings {text image center top bottom left right none} + +if {0} { + proc now {} { set ::now [clock clicks -milliseconds] } + proc tick {} { puts -nonewline stderr "+" ; flush stderr } + proc tock {} { + set then $::now; set ::now [clock clicks -milliseconds] + puts stderr " [expr {$::now - $then}] ms" + } +} else { + proc now {} {} ; proc tick {} {} ; proc tock {} {} +} + +now ; tick +test ttk-8.0 "Setup for 8.X" -body { + ttk::button .ctb + image create photo icon -data $::iconData; + pack .ctb +} +tock + +now +test ttk-8.1 "Test -compound options" -body { + # Exhaustively test each combination. + # Main goal is to make sure no code paths crash. + foreach image {icon ""} { + foreach text {"Hi!" ""} { + foreach compound $::compoundStrings { + .ctb configure -image $image -text $text -compound $compound + update; tick + } + } + } +} +tock + +test ttk-8.2 "Test -compound options with regular button" -body { + button .rtb + pack .rtb + + foreach image {"" icon} { + foreach text {"Hi!" ""} { + foreach compound [lrange $::compoundStrings 2 end] { + .rtb configure -image $image -text $text -compound $compound + update; tick + } + } + } +} +tock + +test ttk-8.3 "Rerun test 8.1" -body { + foreach image {icon ""} { + foreach text {"Hi!" ""} { + foreach compound $::compoundStrings { + .ctb configure -image $image -text $text -compound $compound + update; tick + } + } + } +} +tock + +test ttk-8.4 "ImageChanged" -body { + ttk::button .b -image icon + icon blank +} -cleanup { destroy .b } + +#------------------------------------------------------------------------ + +test ttk-9.1 "Traces on nonexistant namespaces" -body { + ttk::checkbutton .tcb -variable foo::bar +} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob + +test ttk-9.2 "Traces on nonexistant namespaces II" -body { + ttk::checkbutton .tcb -variable X + .tcb configure -variable foo::bar +} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob + +test ttk-9.3 "Restore saved options on configure error" -body { + .tcb cget -variable +} -result X + +test ttk-9.4 "Textvariable tests" -body { + set tcbLabel "Testing..." + .tcb configure -textvariable tcbLabel + .tcb cget -text +} -result "Testing..." + +# Changing -text has no effect if there is a linked -textvariable. +# Compatible with core widget. +test ttk-9.5 "Change -text" -body { + .tcb configure -text "Changed -text" + .tcb cget -text +} -result "Testing..." + +# Unset -textvariable clears the text. +# NOTE: this is different from core widgets, which automagically reinitalize +# the -textvariable to the last value of -text. +# +test ttk-9.6 "Unset -textvariable" -body { + unset tcbLabel + list [info exists tcbLabel] [.tcb cget -text] +} -result [list 0 ""] + +test ttk-9.7 "Unset textvariable, comparison" -body { +# +# NB: ttk::label behaves differently from the standard label here; +# NB: this is on purpose: I believe the standard behaviour is the Wrong Thing +# + unset -nocomplain V1 V2 + label .l -text Foo ; ttk::label .tl -text Foo + + .l configure -textvariable V1 ; .tl configure -textvariable V2 + list [set V1] [info exists V2] +} -cleanup { destroy .l .tl } -result [list Foo 0] + +test ttk-9.8 "-textvariable overrides -text" -body { + ttk::label .tl -textvariable TV + set TV Foo + .tl configure -text Bar + .tl cget -text +} -cleanup { destroy .tl } -result "Foo" + +# +# Frame widget tests: +# + +test ttk-10.1 "ttk::frame -class resource" -body { + ttk::frame .f -class Foo +} -result .f + +test ttk-10.2 "Check widget class" -body { + winfo class .f +} -result Foo + +test ttk-10.3 "Check class resource" -body { + .f cget -class +} -result Foo + +test ttk-10.4 "Try to modify class resource" -body { + .f configure -class Bar +} -returnCodes 1 -match glob -result "*read-only option*" + +test ttk-10.5 "Check class resource again" -body { + .f cget -class +} -result Foo + +test ttk-11.1 "-state test, setup" -body { + ttk::button .b + .b instate disabled +} -result 0 + +test ttk-11.2 "-state test, disable" -body { + .b configure -state disabled + .b instate disabled +} -result 1 + +test ttk-11.3 "-state test, reenable" -body { + .b configure -state normal + .b instate disabled +} -result 0 + +test ttk-11.4 "-state test, unrecognized -state value" -body { + .b configure -state bogus + .b state +} -result [list] + +test ttk-11.5 "-state test, 'active'" -body { + .b configure -state active + .b state +} -result [list active] -cleanup { .b state !active } + +test ttk-11.6 "-state test, 'readonly'" -body { + .b configure -state readonly + .b state +} -result [list readonly] -cleanup { .b state !readonly } + +test ttk-11.7 "-state test, cleanup" -body { + destroy .b +} + +test ttk-12.1 "-cursor option" -body { + ttk::button .b + .b cget -cursor +} -result {} + +test ttk-12.2 "-cursor option" -body { + .b configure -cursor arrow + .b cget -cursor +} -result arrow + +test ttk-12.3 "-borderwidth frame option" -body { + destroy .t + toplevel .t + raise .t + pack [set t [ttk::frame .t.f]] -expand true -fill x ; + pack [ttk::label $t.l -text "ASDF QWERTY"] -expand true -fill both + foreach theme {default alt} { + ttk::style theme use $theme + foreach relief {flat raised sunken ridge groove solid} { + $t configure -relief $relief + for {set i 5} {$i >= 0} {incr i -1} { + $t configure -borderwidth $i + update + } + } + } +} + +test ttk-12.4 "-borderwidth frame option" -body { + .t.f configure -relief raised + .t.f configure -borderwidth 1 + ttk::style theme use alt + update +} + +test ttk-13.1 "Custom styles -- bad -style option" -body { + ttk::button .tb1 -style badstyle +} -returnCodes 1 -result "*badstyle not found*" -match glob + +test ttk-13.4 "Custom styles -- bad -style option" -body { + ttk::button .tb1 + .tb1 configure -style badstyle +} -cleanup { + destroy .tb1 +} -returnCodes 1 -result "*badstyle not found*" -match glob + +test ttk-13.5 "Custom layouts -- missing element definition" -body { + ttk::style layout badstyle { + NoSuchElement + } + ttk::button .tb1 -style badstyle +} -cleanup { + destroy .tb1 +} -result .tb1 +# @@@ Should: signal an error, possibly a background error. + +# +# See #793909 +# + +test ttk-14.1 "-variable in nonexistant namespace" -body { + ttk::checkbutton .tw -variable ::nsn::foo +} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \ + -match glob -cleanup { destroy .tw } + +test ttk-14.2 "-textvariable in nonexistant namespace" -body { + ttk::label .tw -textvariable ::nsn::foo +} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \ + -match glob -cleanup { destroy .tw } + +test ttk-14.3 "-textvariable in nonexistant namespace" -body { + ttk::entry .tw -textvariable ::nsn::foo +} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \ + -match glob -cleanup { destroy .tw } + + +## Test ensemble processing: +# +# (See also: SF#2021443) +# +proc wrong#args {args} { + return "wrong # args: should be \"$args\"" +} +proc wrong#varargs {varpart args} { + set usage $args + append usage " ?$varpart ...?" + return "wrong # args: should be \"$usage\"" +} + +test ttk-ensemble-0 "style element create: insufficient args" -body { + ttk::style +} -returnCodes 1 -result \ + [wrong#varargs arg ttk::style option] + +test ttk-ensemble-1 "style element create: insufficient args" -body { + ttk::style element +} -returnCodes 1 -result \ + [wrong#varargs arg ttk::style element option] + +test ttk-ensemble-2 "style element create: insufficient args" -body { + ttk::style element create +} -returnCodes 1 -result \ + [wrong#varargs {-option value} ttk::style element create name type] + +test ttk-ensemble-3 "style element create: insufficient args" -body { + ttk::style element create plain.background +} -returnCodes 1 -result \ + [wrong#varargs {-option value} ttk::style element create name type] + +test ttk-ensemble-4 "style element create: insufficient args" -body { + ttk::style element create plain.background from +} -returnCodes 1 -result [wrong#args theme ?element?] + +test ttk-ensemble-5 "style element create: valid" -body { + ttk::style element create plain.background from default +} -returnCodes 0 -result "" + +eval destroy [winfo children .] + +tcltest::cleanupTests + +#*EOF* diff --git a/tests/ttk/validate.test b/tests/ttk/validate.test new file mode 100644 index 0000000..417deac --- /dev/null +++ b/tests/ttk/validate.test @@ -0,0 +1,277 @@ +## +## Entry widget validation tests +## Derived from core test suite entry-19.1 through entry-19.20 +## + +package require Tk 8.5 +package require tcltest 2.1 +namespace import -force tcltest::* + +loadTestedCommands + +testConstraint ttkEntry 1 +testConstraint coreEntry [expr {![testConstraint ttkEntry]}] + +eval tcltest::configure $argv + +test validate-0.0 "Setup" -constraints ttkEntry -body { + rename entry {} + interp alias {} entry {} ttk::entry + return; +} + +test validate-0.1 "More setup" -body { + destroy .e + catch {unset ::e} + catch {unset ::vVals} + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + ; + pack .e + proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 1 + } +} + +# The validation tests build each one upon the previous, so cascading +# failures aren't good +# +test validate-1.1 {entry widget validation - insert} -body { + .e insert 0 a + set ::vVals +} -result {.e 1 0 a {} a all key} + +test validate-1.2 {entry widget validation - insert} -body { + .e insert 1 b + set ::vVals +} -result {.e 1 1 ab a b all key} + +test validate-1.3 {entry widget validation - insert} -body { + .e insert end c + set ::vVals +} -result {.e 1 2 abc ab c all key} + +test validate-1.4 {entry widget validation - insert} -body { + .e insert 1 123 + list $::vVals $::e +} -result {{.e 1 1 a123bc abc 123 all key} a123bc} + +test validate-1.5 {entry widget validation - delete} -body { + .e delete 2 + set ::vVals +} -result {.e 0 2 a13bc a123bc 2 all key} + +test validate-1.6 {entry widget validation - delete} -body { + .e configure -validate key + .e delete 1 3 + set ::vVals +} -result {.e 0 1 abc a13bc 13 key key} + +test validate-1.7 {entry widget validation - vmode focus} -body { + set ::vVals {} + .e configure -validate focus + .e insert end d + set ::vVals +} -result {} + +test validate-1.8 {entry widget validation - vmode focus} -body { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} -result {.e -1 -1 abcd abcd {} focus focusin} + +test validate-1.9 {entry widget validation - vmode focus} -body { + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} -result {.e -1 -1 abcd abcd {} focus focusout} + +.e configure -validate all +test validate-1.10 {entry widget validation - vmode all} -body { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} -result {.e -1 -1 abcd abcd {} all focusin} + +test validate-1.11 {entry widget validation} -body { + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} -result {.e -1 -1 abcd abcd {} all focusout} +.e configure -validate focusin + +test validate-1.12 {entry widget validation} -body { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} -result {.e -1 -1 abcd abcd {} focusin focusin} + +test validate-1.13 {entry widget validation} -body { + set ::vVals {} + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} -result {} +.e configure -validate focuso + +test validate-1.14 {entry widget validation} -body { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} -result {} + +test validate-1.15 {entry widget validation} -body { + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} -result {.e -1 -1 abcd abcd {} focusout focusout} + +# DIFFERENCE: core entry temporarily sets "-validate all", ttk::entry doesn't. +test validate-1.16 {entry widget validation} -body { + .e configure -validate all + list [.e validate] $::vVals +} -result {1 {.e -1 -1 abcd abcd {} all forced}} + +# DIFFERENCE: ttk::entry does not perform validation when setting the -variable +test validate-1.17 {entry widget validation} -constraints coreEntry -body { + .e configure -validate all + set ::e newdata + list [.e cget -validate] $::vVals +} -result {all {.e -1 -1 newdata abcd {} all forced}} + +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 0 +} + +test validate-1.18 {entry widget validation} -constraints coreEntry -body { + .e configure -validate all + set ::e nextdata + list [.e cget -validate] $::vVals +} -result {none {.e -1 -1 nextdata newdata {} all forced}} +# DIFFERENCE: ttk::entry doesn't validate when setting linked -variable +# DIFFERENCE: ttk::entry doesn't disable validation + +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + set ::e mydata + return 1 +} + +## This sets validate to none because it shows that we prevent a possible +## loop condition in the validation, when the entry textvar is also set +test validate-1.19 {entry widget validation} -constraints coreEntry -body { + .e configure -validate all + .e validate + list [.e cget -validate] [.e get] $::vVals +} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}} + +## This leaves validate alone because we trigger validation through the +## textvar (a write trace), and the write during validation triggers +## nothing (by definition of avoiding loops on var traces). This is +## one of those "dangerous" conditions where the user will have a +## different value in the entry widget shown as is in the textvar. + +# DIFFERENCE: ttk entry doesn't get out of sync w/textvar +test validate-1.20 {entry widget validation} -constraints coreEntry -body { + .e configure -validate all + set ::e testdata + list [.e cget -validate] [.e get] $::e $::vVals +} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} + +# +# New tests, -JE: +# +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + .e delete 0 end; + .e insert end dovaldata + return 0 +} +test validate-2.1 "Validation script changes value" -body { + .e configure -validate none + set ::e testdata + .e configure -validate all + .e validate + list [.e get] $::e $::vVals +} -result {dovaldata dovaldata {.e -1 -1 testdata testdata {} all forced}} +# DIFFERENCE: core entry disables validation, ttk entry does not. + +destroy .e +catch {unset ::e ::vVals} + +# See bug #1236979 + +test validate-2.2 "configure in -validatecommand" -body { + proc validate-2.2 {win str} { + $win configure -foreground black + return 1 + } + ttk::entry .e -textvariable var -validatecommand {validate-2.2 %W %P} + .e validate +} -result 1 -cleanup { destroy .e } + + +### invalid state behavior +# + +test validate-3.0 "Setup" -body { + set ::E "123" + ttk::entry .e \ + -validatecommand {string is integer -strict %P} \ + -validate all \ + -textvariable ::E \ + ; + return [list [.e get] [.e state]] +} -result [list 123 {}] + +test validate-3.1 "insert - valid" -body { + .e insert end "4" + return [list [.e get] [.e state]] +} -result [list 1234 {}] + +test validate-3.2 "insert - invalid" -body { + .e insert end "X" + return [list [.e get] [.e state]] +} -result [list 1234 {}] + +test validate-3.3 "force invalid value" -body { + append ::E "XY" + return [list [.e get] [.e state]] +} -result [list 1234XY {}] + +test validate-3.4 "revalidate" -body { + return [list [.e validate] [.e get] [.e state]] +} -result [list 0 1234XY {invalid}] + +testConstraint NA 0 +# the next two tests (used to) exercise validation lockout protection -- +# if the widget is currently invalid, all edits are allowed. +# This behavior is currently disabled. +# +test validate-3.5 "all edits allowed while invalid" -constraints NA -body { + .e delete 4 + return [list [.e get] [.e state]] +} -result [list 1234Y {invalid}] + +test validate-3.6 "...until the value becomes valid" -constraints NA -body { + .e delete 4 + return [list [.e get] [.e state]] +} -result [list 1234 {}] + +test validate-3.last "Cleanup" -body { destroy .e } + + +### +tcltest::cleanupTests diff --git a/tests/ttk/vsapi.test b/tests/ttk/vsapi.test new file mode 100644 index 0000000..bb88fef --- /dev/null +++ b/tests/ttk/vsapi.test @@ -0,0 +1,47 @@ +# -*- tcl -*- +# + +package require Tk 8.5 +package require tcltest ; namespace import -force tcltest::* +loadTestedCommands + +testConstraint xpnative \ + [expr {[lsearch -exact [ttk::style theme names] xpnative] != -1}] + +test vsapi-1.1 "WINDOW WP_SMALLCLOSEBUTTON" -constraints {xpnative} -body { + ttk::style element create smallclose vsapi \ + WINDOW 19 {disabled 4 pressed 3 active 2 {} 1} + ttk::style layout CloseButton {CloseButton.smallclose -sticky news} + ttk::button .b -style CloseButton + pack .b -expand true -fill both + list [winfo reqwidth .b] [winfo reqheight .b] +} -cleanup { destroy .b } -result [list 13 13] + +test vsapi-1.2 "EXPLORERBAR EBP_HEADERPIN" -constraints {xpnative} -body { + ttk::style element create pin vsapi \ + EXPLORERBAR 3 { + {pressed !selected} 3 + {active !selected} 2 + {pressed selected} 6 + {active selected} 5 + {selected} 4 + {} 1 + } + ttk::style layout Explorer.Pin {Explorer.Pin.pin -sticky news} + ttk::checkbutton .pin -style Explorer.Pin + pack .pin -expand true -fill both + list [winfo reqwidth .pin] [winfo reqheight .pin] +} -cleanup { destroy .pin } -result [list 16 16] + +test vsapi-1.3 "EXPLORERBAR EBP_HEADERCLOSE" -constraints {xpnative} -body { + ttk::style element create headerclose vsapi \ + EXPLORERBAR 2 {pressed 3 active 2 {} 1} + ttk::style layout Explorer.CloseButton { + Explorer.CloseButton.headerclose -sticky news + } + ttk::button .b -style Explorer.CloseButton + pack .b -expand true -fill both + list [winfo reqwidth .b] [winfo reqheight .b] +} -cleanup { destroy .b } -result [list 16 16] + +tcltest::cleanupTests diff --git a/tests/unixButton.test b/tests/unixButton.test index 77c1112..a51e259 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -9,10 +9,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # Create entries in the option database to be sure that geometry options @@ -193,5 +190,5 @@ test unixbutton-2.1 {disabled coloring check, bug 669595} unix { deleteWindows # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index 46191a7..1e8f03b 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands setupbg @@ -200,7 +197,7 @@ test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} unix { update wm geometry .t2 } {200x200+0+0} -test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} unix { +test unixEmbed-3.2a {ContainerEventProc procedure, disallow position changes} unix { deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 @@ -558,18 +555,5 @@ test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix # cleanup deleteWindows cleanupbg -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/unixFont.test b/tests/unixFont.test index f703ae0..27826d4 100644 --- a/tests/unixFont.test +++ b/tests/unixFont.test @@ -13,29 +13,30 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint hasArial 1 -testConstraint hasCourierNew 1 -testConstraint hasTimesNew 1 -set xlsf [auto_execok xlsfonts] -if {[llength $xlsf]} { - foreach {constraint font} { - hasArial arial - hasCourierNew "courier new" - hasTimesNew "times new roman" - } { - if {![catch {eval exec $xlsf [list *-$font-*]} res] - && ![string match *unmatched* $res]} { - # Newer Unix systems have more default fonts installed, - # so we can't rely on fallbacks for fonts to need to - # fall back on anything. - testConstraint $constraint 0 +if {[tk windowingsystem] eq "x11"} { + set xlsf [auto_execok xlsfonts] +} +foreach {constraint font} { + hasArial arial + hasCourierNew "courier new" + hasTimesNew "times new roman" +} { + if {[tk windowingsystem] eq "x11"} { + testConstraint $constraint 1 + if {[llength $xlsf]} { + if {![catch {eval exec $xlsf [list *-$font-*]} res] + && ![string match *unmatched* $res]} { + # Newer Unix systems have more default fonts installed, + # so we can't rely on fallbacks for fonts to need to + # fall back on anything. + testConstraint $constraint 0 + } } + } else { + testConstraint $constraint 0 } } @@ -313,18 +314,5 @@ test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} unix { } {0 1 1 1 1 2} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/unixMenu.test b/tests/unixMenu.test index a43f6f5..802a7c2 100644 --- a/tests/unixMenu.test +++ b/tests/unixMenu.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands test unixMenu-1.1 {TkpNewMenu - normal menu} unix { @@ -304,7 +301,7 @@ test unixMenu-17.1 {GetMenuSeparatorGeometry} unix { list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-18.1 {GetTearoffEntryGeometry} unix { +test unixMenu-18.1 {GetTearoffEntryGeometry} {unix nonUnixUserInteraction} { catch {destroy .m1} menubutton .mb -text "test" -menu .mb.m menu .mb.m @@ -554,7 +551,7 @@ test unixMenu-20.1 {DrawTearoffEntry - menubar} unix { . configure -menu .m1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-20.2 {DrawTearoffEntry - non-menubar} unix { +test unixMenu-20.2 {DrawTearoffEntry - non-menubar} {unix nonUnixUserInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -820,7 +817,7 @@ test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} unix { .m1 add separator list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} { +test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unix nonUnixUserInteraction} { catch {destroy .m1} menubutton .mb -text "test" -menu .mb.m menu .mb.m @@ -893,7 +890,7 @@ test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or e .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unixOnly testImageType} { +test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unix testImageType} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -947,5 +944,5 @@ test unixMenu-26.1 {TkpMenuInit - nothing to do} {} {} # cleanup deleteWindows -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/unixSelect.test b/tests/unixSelect.test index cfb98ea..c3ed11d 100644 --- a/tests/unixSelect.test +++ b/tests/unixSelect.test @@ -10,10 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands global longValue selValue selInfo @@ -107,7 +104,7 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j } -test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} {unixOnly} { +test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} unix { setupbg entry .e pack .e @@ -119,7 +116,7 @@ test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} {unixOnly} { destroy .e set result } {5} -test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} {unixOnly} { +test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} unix { setupbg dobg { entry .e; pack .e; update @@ -131,7 +128,7 @@ test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} { list [string equal \u00fc? $x] \ [string length $x] [string bytelength $x] } {1 2 3} -test unixSelect-1.4 {TkSelGetSelection procedure: simple i18n text, iso2022} {unixOnly} { +test unixSelect-1.4 {TkSelGetSelection procedure: simple i18n text, iso2022} unix { setupbg setup selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ @@ -147,7 +144,7 @@ test unixSelect-1.4 {TkSelGetSelection procedure: simple i18n text, iso2022} {un cleanupbg lappend result $selInfo } {1 2 4 {COMPOUND_TEXT 0 4000}} -test unixSelect-1.5 {TkSelGetSelection procedure: INCR i18n text, iso2022} {unixOnly} { +test unixSelect-1.5 {TkSelGetSelection procedure: INCR i18n text, iso2022} unix { # This test is subtle. The selection ends up getting fetched twice by # Tk: once to compute the length, and again to actually send the data. @@ -170,7 +167,7 @@ test unixSelect-1.5 {TkSelGetSelection procedure: INCR i18n text, iso2022} {unix cleanupbg lappend result $selInfo } {1 8000 8002 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}} -test unixSelect-1.6 {TkSelGetSelection procedure: simple i18n text, iso2022} {unixOnly} { +test unixSelect-1.6 {TkSelGetSelection procedure: simple i18n text, iso2022} unix { setupbg setup selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ @@ -186,7 +183,7 @@ test unixSelect-1.6 {TkSelGetSelection procedure: simple i18n text, iso2022} {un cleanupbg lappend result $selInfo } {1 2 4 {COMPOUND_TEXT 0 4000}} -test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { +test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} unix { setupbg dobg "entry .e; pack .e; update .e insert 0 \[encoding convertfrom identity \\u00fcber\]$longValue @@ -195,7 +192,7 @@ test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { cleanupbg set result } [expr {5 + [string bytelength $longValue]}] -test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { +test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} unix { setupbg dobg { entry .e; pack .e; update @@ -207,7 +204,7 @@ test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { list [string equal [string repeat x 3999]\u00fc $x] \ [string length $x] [string bytelength $x] } {1 4000 4001} -test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { +test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} unix { setupbg dobg { entry .e; pack .e; update @@ -219,7 +216,7 @@ test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { list [string equal \u00fc[string repeat x 3999] $x] \ [string length $x] [string bytelength $x] } {1 4000 4001} -test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { +test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text} unix { setupbg dobg { entry .e; pack .e; update @@ -234,7 +231,7 @@ test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { # Now some tests to make sure that the right thing is done when # transferring UTF8 selections, to prevent [Bug 614650] and its ilk # from rearing its ugly head again. -test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixOnly} { +test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { setupbg dobg { entry .e; pack .e; update @@ -246,7 +243,7 @@ test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixO list [string equal [string repeat x 3999]\u00fc $x] \ [string length $x] [string bytelength $x] } {1 4000 4001} -test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixOnly} { +test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { setupbg dobg { entry .e; pack .e; update @@ -258,7 +255,7 @@ test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixO list [string equal \u00fc[string repeat x 3999] $x] \ [string length $x] [string bytelength $x] } {1 4000 4001} -test unixSelect-1.13 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixOnly} { +test unixSelect-1.13 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { setupbg dobg { entry .e; pack .e; update @@ -270,7 +267,7 @@ test unixSelect-1.13 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixO list [string equal [string repeat x 3999]\u00fc[string repeat x 4000] $x] \ [string length $x] [string bytelength $x] } {1 8000 8001} -test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} {unixOnly} { +test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} unix { setupbg entry .e pack .e @@ -282,7 +279,7 @@ test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} {uni destroy .e set result } {5} -test unixSelect-1.15 {TkSelGetSelection procedure: simple i18n text, utf-8} {unixOnly} { +test unixSelect-1.15 {TkSelGetSelection procedure: simple i18n text, utf-8} unix { setupbg dobg { entry .e; pack .e; update @@ -294,7 +291,7 @@ test unixSelect-1.15 {TkSelGetSelection procedure: simple i18n text, utf-8} {uni list [string equal \u00fc\u0444 $x] \ [string length $x] [string bytelength $x] } {1 2 4} -test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixOnly} { +test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { setupbg dobg { entry .e; pack .e; update @@ -306,7 +303,7 @@ test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixO list [string equal [string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ [string length $x] [string bytelength $x] } {1 2121 4221} -test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixOnly} { +test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { setupbg dobg { entry .e; pack .e; update @@ -318,7 +315,7 @@ test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixO list [string equal i[string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ [string length $x] [string bytelength $x] } {1 2122 4222} -test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixOnly} { +test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { setupbg dobg { text .t; pack .t; update @@ -332,7 +329,7 @@ test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixO list [string equal [string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ [string length $x] [string bytelength $x] } {1 2121 4221} -test unixSelect-1.19 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixOnly} { +test unixSelect-1.19 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { setupbg dobg { text .t; pack .t; update @@ -346,7 +343,7 @@ test unixSelect-1.19 {TkSelGetSelection procedure: INCR i18n text, utf-8} {unixO list [string equal i[string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ [string length $x] [string bytelength $x] } {1 2122 4222} -test unixSelect-1.20 {Automatic UTF8_STRING support for selection handle} {unixOnly} { +test unixSelect-1.20 {Automatic UTF8_STRING support for selection handle} unix { # See Bug #666346 "Selection handling crashes under KDE 3.0" label .l selection handle .l [list handler STRING] @@ -358,5 +355,5 @@ test unixSelect-1.20 {Automatic UTF8_STRING support for selection handle} {unixO } "This is the selection value" # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/unixWm.test b/tests/unixWm.test index 60cd9d9..d579fc7 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -8,15 +8,10 @@ # All rights reserved. package require tcltest 2.2 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::interpreter -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile +namespace import -force ::tk::test:loadTkCommand proc sleep ms { global x @@ -37,7 +32,7 @@ proc makeToplevels {} { set i 1 foreach geom {+20+80 +80+20 +0+0} { - catch {destroy .t} + destroy .t test unixWm-1.$i {initial window position} unix { toplevel .t -width 200 -height 150 wm geom .t $geom @@ -53,7 +48,7 @@ foreach geom {+20+80 +80+20 +0+0} { # this just makes sure that things are consistent between moves. set i 1 -catch {destroy .t} +destroy .t toplevel .t -width 100 -height 150 wm geom .t +200+200 update @@ -102,7 +97,7 @@ foreach geom {+20+80 +100+40 +0+0} { } test unixWm-5.1 {compounded state changes} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 100 wm geometry .t +100+100 update @@ -111,7 +106,7 @@ test unixWm-5.1 {compounded state changes} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {1 normal} test unixWm-5.2 {compounded state changes} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 100 wm geometry .t +100+100 update @@ -121,7 +116,7 @@ test unixWm-5.2 {compounded state changes} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {0 withdrawn} test unixWm-5.3 {compounded state changes} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 100 wm geometry .t +100+100 update @@ -132,7 +127,7 @@ test unixWm-5.3 {compounded state changes} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {1 normal} test unixWm-5.4 {compounded state changes} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 100 wm geometry .t +100+100 update @@ -142,7 +137,7 @@ test unixWm-5.4 {compounded state changes} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {0 iconic} test unixWm-5.5 {compounded state changes} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 100 wm geometry .t +100+100 update @@ -151,7 +146,7 @@ test unixWm-5.5 {compounded state changes} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {0 withdrawn} test unixWm-5.6 {compounded state changes} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 100 wm geometry .t +100+100 update @@ -161,7 +156,7 @@ test unixWm-5.6 {compounded state changes} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {1 normal} test unixWm-5.7 {compounded state changes} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 100 wm geometry .t +100+100 update @@ -170,7 +165,7 @@ test unixWm-5.7 {compounded state changes} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {0 iconic} -catch {destroy .t} +destroy .t toplevel .t -width 200 -height 100 wm geom .t +10+10 wm minsize .t 1 1 @@ -221,7 +216,7 @@ test unixWm-6.4 {size changes} {unix nonPortable userInteraction} { sleep 200 test unixWm-6.5 {window initially iconic} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 30 wm geometry .t +0+0 wm title .t 2 @@ -232,7 +227,7 @@ test unixWm-6.5 {window initially iconic} {unix nonPortable} { list [winfo ismapped .t] [wm state .t] } {1 normal} -catch {destroy .m} +destroy .m toplevel .m wm overrideredirect .m 1 foreach i {{Test label} Another {Yet another} {Last label}} j {1 2 3} { @@ -253,11 +248,11 @@ test unixWm-7.3 {override_redirect and Tk_MoveTopLevelWindow} unix { list [winfo ismapped .m] } 0 destroy .m -catch {destroy .t} +destroy .t test unixWm-8.1 {icon windows} unix { - catch {destroy .t} - catch {destroy .icon} + destroy .t + destroy .icon toplevel .t -width 100 -height 30 wm geometry .t +0+0 toplevel .icon -width 50 -height 50 -bg red @@ -265,18 +260,18 @@ test unixWm-8.1 {icon windows} unix { list [catch {wm withdraw .icon} msg] $msg } {1 {can't withdraw .icon: it is an icon for .t}} test unixWm-8.2 {icon windows} unix { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 30 list [catch {wm iconwindow} msg] $msg } {1 {wrong # args: should be "wm option window ?arg ...?"}} test unixWm-8.3 {icon windows} unix { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 30 list [catch {wm iconwindow .t b c} msg] $msg } {1 {wrong # args: should be "wm iconwindow window ?pathName?"}} test unixWm-8.4 {icon windows} unix { - catch {destroy .t} - catch {destroy .icon} + destroy .t + destroy .icon toplevel .t -width 100 -height 30 wm geom .t +0+0 set result [wm iconwindow .t] @@ -292,19 +287,19 @@ test unixWm-8.4 {icon windows} unix { lappend result [winfo ismapped .t] [winfo ismapped .icon] } {.icon icon {} withdrawn 1 0 0 0} test unixWm-8.5 {icon windows} unix { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 30 list [catch {wm iconwindow .t .gorp} msg] $msg } {1 {bad window path name ".gorp"}} test unixWm-8.6 {icon windows} unix { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 30 frame .t.icon -width 50 -height 50 -bg red list [catch {wm iconwindow .t .t.icon} msg] $msg } {1 {can't use .t.icon as icon window: not at top level}} test unixWm-8.7 {icon windows} unix { - catch {destroy .t} - catch {destroy .icon} + destroy .t + destroy .icon toplevel .t -width 100 -height 30 wm geom .t +0+0 toplevel .icon -width 50 -height 50 -bg red @@ -314,10 +309,10 @@ test unixWm-8.7 {icon windows} unix { wm iconwindow .t .icon2 lappend result [wm iconwindow .t] [wm state .icon] [wm state .icon2] } {.icon icon normal .icon2 withdrawn icon} -catch {destroy .icon2} +destroy .icon2 test unixWm-8.8 {icon windows} unix { - catch {destroy .t} - catch {destroy .icon} + destroy .t + destroy .icon toplevel .icon -width 50 -height 50 -bg red wm geom .icon +0+0 update @@ -333,8 +328,8 @@ test unixWm-8.9 {icon windows} {unix nonPortable} { # This test is non-portable because some window managers will # destroy an icon window when it's associated window is destroyed. - catch {destroy .t} - catch {destroy .icon} + destroy .t + destroy .icon toplevel .t -width 100 -height 30 toplevel .icon -width 50 -height 50 -bg red wm geom .t +0+0 @@ -376,7 +371,7 @@ test unixWm-8.10.2 {test for memory leaks} unix { } 1 test unixWm-9.1 {TkWmMapWindow procedure, client property} {unix testwrapper} { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 50 wm geom .t +0+0 wm client .t Test_String @@ -384,7 +379,7 @@ test unixWm-9.1 {TkWmMapWindow procedure, client property} {unix testwrapper} { testprop [testwrapper .t] WM_CLIENT_MACHINE } {Test_String} test unixWm-9.2 {TkWmMapWindow procedure, command property} {unix testwrapper} { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 50 wm geom .t +0+0 wm command .t "test command" @@ -394,7 +389,7 @@ test unixWm-9.2 {TkWmMapWindow procedure, command property} {unix testwrapper} { command } test unixWm-9.3 {TkWmMapWindow procedure, iconic windows} unix { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 300 -bg blue wm geom .t +0+0 wm iconify .t @@ -402,7 +397,7 @@ test unixWm-9.3 {TkWmMapWindow procedure, iconic windows} unix { winfo ismapped .t } {0} test unixWm-9.4 {TkWmMapWindow procedure, icon windows} unix { - catch {destroy .t} + destroy .t sleep 500 toplevel .t -width 100 -height 50 -bg blue wm iconwindow . .t @@ -410,17 +405,15 @@ test unixWm-9.4 {TkWmMapWindow procedure, icon windows} unix { set result [winfo ismapped .t] } {0} test unixWm-9.5 {TkWmMapWindow procedure, normal windows} unix { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 20 wm geom .t +0+0 update winfo ismapped .t } {1} -testConstraint testmenubar [llength [info commands testmenubar]] - test unixWm-10.1 {TkWmDeadWindow procedure, canceling UpdateGeometry idle handler} unix { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 50 wm geom .t +0+0 update @@ -428,8 +421,8 @@ test unixWm-10.1 {TkWmDeadWindow procedure, canceling UpdateGeometry idle handle destroy .t } {} test unixWm-10.2 {TkWmDeadWindow procedure, destroying menubar} {unix testmenubar} { - catch {destroy .t} - catch {destroy .f} + destroy .t + destroy .f toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 update @@ -452,13 +445,13 @@ test unixWm-11.3 {Tk_WmCmd procedure, miscellaneous errors} unix { list [catch {wm iconify bogus} msg] $msg } {1 {bad window path name "bogus"}} test unixWm-11.4 {Tk_WmCmd procedure, miscellaneous errors} unix { - catch {destroy .b} + destroy .b button .b -text hello list [catch {wm geometry .b} msg] $msg } {1 {window ".b" isn't a top-level window}} -catch {destroy .t} -catch {destroy .icon} +destroy .t +destroy .icon toplevel .t -width 100 -height 50 wm geom .t +0+0 @@ -517,7 +510,7 @@ test unixWm-13.2 {Tk_WmCmd procedure, "client" option} {unix testwrapper} { lappend result [wm client .t] [testprop [testwrapper .t] WM_CLIENT_MACHINE] } {{} Test_String New {} {}} test unixWm-13.3 {Tk_WmCmd procedure, "client" option, unmapped window} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm client .t2 Test_String wm client .t2 {} @@ -529,7 +522,7 @@ test unixWm-14.1 {Tk_WmCmd procedure, "colormapwindows" option} unix { list [catch {wm colormapwindows .t 12 13} msg] $msg } {1 {wrong # args: should be "wm colormapwindows window ?windowList?"}} test unixWm-14.2 {Tk_WmCmd procedure, "colormapwindows" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 200 -height 200 -colormap new wm geom .t2 +0+0 frame .t2.a -width 100 -height 30 @@ -549,7 +542,7 @@ test unixWm-14.4 {Tk_WmCmd procedure, "colormapwindows" option} unix { list [catch {wm colormapwindows . foo} msg] $msg } {1 {bad window path name "foo"}} test unixWm-14.5 {Tk_WmCmd procedure, "colormapwindows" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 200 -height 200 -colormap new wm geom .t2 +0+0 frame .t2.a -width 100 -height 30 @@ -560,7 +553,7 @@ test unixWm-14.5 {Tk_WmCmd procedure, "colormapwindows" option} unix { wm colormapwindows .t2 } {.t2.c .t2 .t2.a} test unixWm-14.6 {Tk_WmCmd procedure, "colormapwindows" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 200 -height 200 wm geom .t2 +0+0 frame .t2.a -width 100 -height 30 @@ -571,14 +564,14 @@ test unixWm-14.6 {Tk_WmCmd procedure, "colormapwindows" option} unix { wm colormapwindows .t2 } {.t2.b .t2.a} test unixWm-14.7 {Tk_WmCmd procedure, "colormapwindows" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 200 -height 200 -colormap new wm geom .t2 +0+0 set x [wm colormapwindows .t2] wm colormapwindows .t2 {} list $x [wm colormapwindows .t2] } {{} {}} -catch {destroy .t2} +destroy .t2 test unixWm-15.1 {Tk_WmCmd procedure, "command" option} unix { list [catch {wm command .t 12 13} msg] $msg @@ -599,7 +592,7 @@ test unixWm-15.3 {Tk_WmCmd procedure, "command" option} {unix testwrapper} { command } {new command} {} {}} test unixWm-15.4 {Tk_WmCmd procedure, "command" option, window not mapped} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm geom .t2 +0+0 wm command .t2 "test command" @@ -615,7 +608,7 @@ test unixWm-16.1 {Tk_WmCmd procedure, "deiconify" option} unix { list [catch {wm deiconify .t 12} msg] $msg } {1 {wrong # args: should be "wm deiconify window"}} test unixWm-16.2 {Tk_WmCmd procedure, "deiconify" option} unix { - catch {destroy .icon} + destroy .icon toplevel .icon -width 50 -height 50 -bg red wm iconwindow .t .icon set result [list [catch {wm deiconify .icon} msg] $msg] @@ -653,7 +646,7 @@ test unixWm-18.2 {Tk_WmCmd procedure, "frame" option} {unix nonPortable} { expr [wm frame .t] == [winfo id .t] } {0} test unixWm-18.3 {Tk_WmCmd procedure, "frame" option} {unix nonPortable} { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm geom .t2 +0+0 wm overrideredirect .t2 1 @@ -677,7 +670,7 @@ test unixWm-19.3 {Tk_WmCmd procedure, "geometry" option} {unix nonPortable} { wm geometry .t } {100x50+10-4} test unixWm-19.4 {Tk_WmCmd procedure, "geometry" option} {unix nonPortable} { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm geom .t2 -5+10 listbox .t2.l -width 30 -height 12 -setgrid 1 @@ -696,7 +689,7 @@ test unixWm-19.5 {Tk_WmCmd procedure, "geometry" option} {unix nonPortable} { update lappend result [wm geometry .t] } {150x300+5+6 100x50+5+6} -test unixWm-19.6 {Tk_WmCmd procedure, "geometry" option} {unix} { +test unixWm-19.6 {Tk_WmCmd procedure, "geometry" option} unix { list [catch {wm geometry .t qrs} msg] $msg } {1 {bad geometry specifier "qrs"}} @@ -739,8 +732,8 @@ test unixWm-20.11 {Tk_WmCmd procedure, "grid" option} unix { list [catch {wm grid .t 10 11 12 -1} msg] $msg } {1 {heightInc can't be <= 0}} -catch {destroy .t} -catch {destroy .icon} +destroy .t +destroy .icon toplevel .t -width 100 -height 50 wm geom .t +0+0 update @@ -764,7 +757,7 @@ test unixWm-21.3 {Tk_WmCmd procedure, "group" option} {unix testwrapper} { lappend result [wm group .t] $bit } {{} . 0x40 {} 0x0} test unixWm-21.4 {Tk_WmCmd procedure, "group" option, make window exist} {unix testwrapper} { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm geom .t2 +0+0 wm group .t .t2 @@ -774,8 +767,8 @@ test unixWm-21.4 {Tk_WmCmd procedure, "group" option, make window exist} {unix t set result } {0} test unixWm-21.5 {Tk_WmCmd procedure, "group" option, create leader wrapper} {unix testwrapper} { - catch {destroy .t2} - catch {destroy .t3} + destroy .t2 + destroy .t3 toplevel .t2 -width 120 -height 300 wm geometry .t2 +0+0 toplevel .t3 -width 120 -height 300 @@ -810,7 +803,7 @@ test unixWm-23.1 {Tk_WmCmd procedure, "iconify" option} unix { list [catch {wm iconify .t 12} msg] $msg } {1 {wrong # args: should be "wm iconify window"}} test unixWm-23.2 {Tk_WmCmd procedure, "iconify" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm overrideredirect .t2 1 set result [list [catch {wm iconify .t2} msg] $msg] @@ -818,7 +811,7 @@ test unixWm-23.2 {Tk_WmCmd procedure, "iconify" option} unix { set result } {1 {can't iconify ".t2": override-redirect flag is set}} test unixWm-23.3 {Tk_WmCmd procedure, "iconify" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm geom .t2 +0+0 wm transient .t2 .t @@ -827,7 +820,7 @@ test unixWm-23.3 {Tk_WmCmd procedure, "iconify" option} unix { set result } {1 {can't iconify ".t2": it is a transient}} test unixWm-23.4 {Tk_WmCmd procedure, "iconify" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm geom .t2 +0+0 wm iconwindow .t .t2 @@ -836,7 +829,7 @@ test unixWm-23.4 {Tk_WmCmd procedure, "iconify" option} unix { set result } {1 {can't iconify .t2: it is an icon for .t}} test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm geom .t2 +0+0 update @@ -847,7 +840,7 @@ test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} unix { set result } {0} test unixWm-23.6 {Tk_WmCmd procedure, "iconify" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 wm geom .t2 -0+0 update @@ -880,7 +873,7 @@ test unixWm-24.3 {Tk_WmCmd procedure, "iconmask" option} unix { test unixWm-25.1 {Tk_WmCmd procedure, "iconname" option} unix { list [catch {wm icon .t} msg] $msg -} {1 {ambiguous option "icon": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}} +} {1 {ambiguous option "icon": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}} test unixWm-25.2 {Tk_WmCmd procedure, "iconname" option} unix { list [catch {wm iconname .t 12 13} msg] $msg } {1 {wrong # args: should be "wm iconname window ?newName?"}} @@ -922,7 +915,7 @@ test unixWm-27.1 {Tk_WmCmd procedure, "iconwindow" option} unix { list [catch {wm iconwindow .t 12 13} msg] $msg } {1 {wrong # args: should be "wm iconwindow window ?pathName?"}} test unixWm-27.2 {Tk_WmCmd procedure, "iconwindow" option} {unix testwrapper} { - catch {destroy .icon} + destroy .icon toplevel .icon -width 50 -height 50 -bg green set result {} lappend result [wm iconwindow .t] @@ -942,16 +935,16 @@ test unixWm-27.3 {Tk_WmCmd procedure, "iconwindow" option} unix { list [catch {wm iconwindow .t bogus} msg] $msg } {1 {bad window path name "bogus"}} test unixWm-27.4 {Tk_WmCmd procedure, "iconwindow" option} unix { - catch {destroy .b} + destroy .b button .b -text Help set result [list [catch {wm iconwindow .t .b} msg] $msg] destroy .b set result } {1 {can't use .b as icon window: not at top level}} test unixWm-27.5 {Tk_WmCmd procedure, "iconwindow" option} unix { - catch {destroy .icon} + destroy .icon toplevel .icon -width 50 -height 50 -bg green - catch {destroy .t2} + destroy .t2 toplevel .t2 wm geom .t2 -0+0 wm iconwindow .t2 .icon @@ -961,8 +954,8 @@ test unixWm-27.5 {Tk_WmCmd procedure, "iconwindow" option} unix { set result } {1 {.icon is already an icon for .t2}} test unixWm-27.6 {Tk_WmCmd procedure, "iconwindow" option, changing icons} unix { - catch {destroy .icon} - catch {destroy .icon2} + destroy .icon + destroy .icon2 toplevel .icon -width 50 -height 50 -bg green toplevel .icon2 -width 50 -height 50 -bg red set result {} @@ -974,7 +967,7 @@ test unixWm-27.6 {Tk_WmCmd procedure, "iconwindow" option, changing icons} unix set result } {icon normal withdrawn icon} test unixWm-27.7 {Tk_WmCmd procedure, "iconwindow" option, withdrawing icon} unix { - catch {destroy .icon} + destroy .icon toplevel .icon -width 50 -height 50 -bg green wm geometry .icon +0+0 update @@ -986,38 +979,85 @@ test unixWm-27.7 {Tk_WmCmd procedure, "iconwindow" option, withdrawing icon} uni set result } {normal 1 icon 0} -test unixWm-28.1 {Tk_WmCmd procedure, "maxsize" option} {nonPortable} { - wm maxsize .t -} {1137 870} +destroy .t +destroy .icon +toplevel .t -width 100 -height 50 +wm geom .t +0+0 +update -test unixWm-28.2 {Tk_WmCmd procedure, "maxsize" option} {nonPortable} { - # Not portable, because some window managers let applications override - # minsize and maxsize. +test unixWm-28.1 {Tk_WmCmd procedure, "maxsize" option, setting the + maxsize should update WM_NORMAL_HINTS} {testwrapper} { + destroy .t + toplevel .t + wm maxsize .t 300 300 + update + set hints [testprop [testwrapper .t] WM_NORMAL_HINTS] + format {%d %d} [lindex $hints 7] [lindex $hints 8] +} {300 300} - wm maxsize .t 200 150 - wm geom .t 300x200 +test unixWm-28.2 {Tk_WmCmd procedure, "maxsize" option, setting the + maxsize to a value smaller than the current size should + set the maxsize in WM_NORMAL_HINTS} {testwrapper} { + destroy .t + toplevel .t + wm geom .t 400x400 + wm maxsize .t 300 300 update - list [winfo width .t] [winfo height .t] -} {200 150} + set hints [testprop [testwrapper .t] WM_NORMAL_HINTS] + format {%d %d} [lindex $hints 7] [lindex $hints 8] +} {300 300} -catch {destroy .t} -catch {destroy .icon} -toplevel .t -width 100 -height 50 -wm geom .t +0+0 -update +test unixWm-28.3 {Tk_WmCmd procedure, "maxsize" option, setting the + maxsize to a value smaller than the current size should + set the maxsize in WM_NORMAL_HINTS even if the + interactive resizable flag is set to 0} {testwrapper} { + destroy .t + toplevel .t + wm geom .t 400x400 + wm resizable .t 0 0 + wm maxsize .t 300 300 + update + set hints [testprop [testwrapper .t] WM_NORMAL_HINTS] + format {%d %d} [lindex $hints 7] [lindex $hints 8] +} {300 300} -test unixWm-29.1 {Tk_WmCmd procedure, "minsize" option} {nonPortable} { - # Not portable, because some window managers let applications override - # minsize and maxsize. +test unixWm-29.1 {Tk_WmCmd procedure, "minsize" option, setting the + minsize should update WM_NORMAL_HINTS} {testwrapper} { + destroy .t + toplevel .t + wm minsize .t 300 300 + update + set hints [testprop [testwrapper .t] WM_NORMAL_HINTS] + format {%d %d} [lindex $hints 5] [lindex $hints 6] +} {300 300} - wm minsize .t 150 100 - wm geom .t 50x50 +test unixWm-29.2 {Tk_WmCmd procedure, "minsize" option, setting the + minsize to a value larger than the current size should + set the maxsize in WM_NORMAL_HINTS} {testwrapper} { + destroy .t + toplevel .t + wm geom .t 200x200 + wm minsize .t 300 300 update - list [winfo width .t] [winfo height .t] -} {150 100} + set hints [testprop [testwrapper .t] WM_NORMAL_HINTS] + format {%d %d} [lindex $hints 5] [lindex $hints 6] +} {300 300} -catch {destroy .t} -catch {destroy .icon} +test unixWm-29.3 {Tk_WmCmd procedure, "minsize" option, setting the + minsize to a value larger than the current size should + set the minsize in WM_NORMAL_HINTS even if the + interactive resizable flag is set to 0} {testwrapper} { + destroy .t + toplevel .t + wm geom .t 200x200 + wm resizable .t 0 0 + wm minsize .t 300 300 + update + set hints [testprop [testwrapper .t] WM_NORMAL_HINTS] + format {%d %d} [lindex $hints 5] [lindex $hints 6] +} {300 300} + +destroy .t .icon toplevel .t -width 100 -height 50 wm geom .t +0+0 update @@ -1125,7 +1165,7 @@ test unixWm-33.5 {Tk_WmCmd procedure, "resizable" option} unix { list [catch {wm resizable . 0 gorp} msg] $msg } {1 {expected boolean value but got "gorp"}} test unixWm-33.6 {Tk_WmCmd procedure, "resizable" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 200 -height 100 wm geom .t2 +0+0 set result "" @@ -1169,7 +1209,7 @@ test unixWm-35.2 {Tk_WmCmd procedure, "state" option} unix { } {1 {wrong # args: should be "wm state window ?state?"}} test unixWm-35.3 {Tk_WmCmd procedure, "state" option} unix { set result {} - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 120 -height 300 wm geometry .t2 +0+0 lappend result [wm state .t2] @@ -1186,7 +1226,7 @@ test unixWm-35.3 {Tk_WmCmd procedure, "state" option} unix { } {normal normal withdrawn iconic normal} test unixWm-35.4 {Tk_WmCmd procedure, "state" option} unix { set result {} - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 120 -height 300 wm geometry .t2 +0+0 lappend result [wm state .t2] @@ -1216,7 +1256,7 @@ test unixWm-36.2 {Tk_WmCmd procedure, "title" option} {unix testwrapper} { test unixWm-37.3 {Tk_WmCmd procedure, "transient" option} {unix testwrapper} { set result {} - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 120 -height 300 wm geometry .t2 +0+0 update @@ -1232,9 +1272,9 @@ test unixWm-37.3 {Tk_WmCmd procedure, "transient" option} {unix testwrapper} { set result } {{} {} .t 0 {} {}} test unixWm-37.4 {TkWmDeadWindow, destroy on master should clear transient} {unix testwrapper} { - catch {destroy .t2} + destroy .t2 toplevel .t2 - catch {destroy .t3} + destroy .t3 toplevel .t3 wm transient .t2 .t3 update @@ -1243,8 +1283,8 @@ test unixWm-37.4 {TkWmDeadWindow, destroy on master should clear transient} {uni list [wm transient .t2] [testprop [testwrapper .t2] WM_TRANSIENT_FOR] } {{} {}} test unixWm-37.5 {Tk_WmCmd procedure, "transient" option, create master wrapper} {unix testwrapper} { - catch {destroy .t2} - catch {destroy .t3} + destroy .t2 + destroy .t3 toplevel .t2 -width 120 -height 300 wm geometry .t2 +0+0 toplevel .t3 -width 120 -height 300 @@ -1260,7 +1300,7 @@ test unixWm-38.1 {Tk_WmCmd procedure, "withdraw" option} unix { list [catch {wm withdraw .t 1} msg] $msg } {1 {wrong # args: should be "wm withdraw window"}} test unixWm-38.2 {Tk_WmCmd procedure, "withdraw" option} unix { - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 120 -height 300 wm geometry .t2 +0+0 wm iconwindow .t .t2 @@ -1278,13 +1318,12 @@ test unixWm-38.3 {Tk_WmCmd procedure, "withdraw" option} unix { test unixWm-39.1 {Tk_WmCmd procedure, miscellaneous} unix { list [catch {wm unknown .t} msg] $msg -} {1 {bad option "unknown": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}} +} {1 {bad option "unknown": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}} -catch {destroy .t} -catch {destroy .icon} +destroy .t .icon test unixWm-40.1 {Tk_SetGrid procedure, set grid dimensions before turning on grid} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t wm geometry .t 30x10+0+0 listbox .t.l -height 20 -width 20 -setgrid 1 @@ -1293,7 +1332,7 @@ test unixWm-40.1 {Tk_SetGrid procedure, set grid dimensions before turning on gr wm geometry .t } {30x10+0+0} test unixWm-40.2 {Tk_SetGrid procedure, turning on grid when dimensions already set} unix { - catch {destroy .t} + destroy .t toplevel .t wm geometry .t 200x100+0+0 listbox .t.l -height 20 -width 20 @@ -1305,7 +1344,7 @@ test unixWm-40.2 {Tk_SetGrid procedure, turning on grid when dimensions already } {20x20+0+0} test unixWm-41.1 {ConfigureEvent procedure, internally generated size changes} unix { - catch {destroy .t} + destroy .t toplevel .t -width 400 -height 150 wm geometry .t +0+0 tkwait visibility .t @@ -1316,7 +1355,7 @@ test unixWm-41.1 {ConfigureEvent procedure, internally generated size changes} u lappend result [winfo width .t] [winfo height .t] } {400 150 200 300} test unixWm-41.2 {ConfigureEvent procedure, menubars} {nonPortable testmenubar} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 update @@ -1341,7 +1380,7 @@ test unixWm-41.2 {ConfigureEvent procedure, menubars} {nonPortable testmenubar} [winfo width .t] [winfo height .t] } {{.t.m: 200x20} {.t: 200x300} 0 0 200 20 0 20 200 300} test unixWm-41.3 {ConfigureEvent procedure, synthesized Configure events} unix { - catch {destroy .t} + destroy .t toplevel .t -width 400 -height 150 wm geometry .t +0+0 tkwait visibility .t @@ -1352,7 +1391,7 @@ test unixWm-41.3 {ConfigureEvent procedure, synthesized Configure events} unix { set result } {configured: 400 150} test unixWm-41.4 {ConfigureEvent procedure, synthesized Configure events} unix { - catch {destroy .t} + destroy .t toplevel .t -width 400 -height 150 wm geometry .t +0+0 tkwait visibility .t @@ -1367,7 +1406,7 @@ test unixWm-41.4 {ConfigureEvent procedure, synthesized Configure events} unix { # out how to exercise these procedures reliably. test unixWm-42.1 {WrapperEventProc procedure, map and unmap events} unix { - catch {destroy .t} + destroy .t toplevel .t -width 400 -height 150 wm geometry .t +0+0 tkwait visibility .t @@ -1383,7 +1422,7 @@ test unixWm-42.1 {WrapperEventProc procedure, map and unmap events} unix { } {unmapped 0 mapped 1} test unixWm-43.1 {TopLevelReqProc procedure, embedded in same process} unix { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 200 wm geom .t +0+0 frame .t.f -container 1 -bd 2 -relief raised @@ -1401,7 +1440,7 @@ test unixWm-43.1 {TopLevelReqProc procedure, embedded in same process} unix { } {70 120 70 120} test unixWm-43.2 {TopLevelReqProc procedure, resize causes window to move} \ {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 200 wm geom .t +0+0 update @@ -1416,7 +1455,7 @@ test unixWm-43.2 {TopLevelReqProc procedure, resize causes window to move} \ } {-100 50 300 150} test unixWm-44.1 {UpdateGeometryInfo procedure, width/height computation} unix { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 200 wm geometry .t +30+40 wm overrideredirect .t 1 @@ -1426,7 +1465,7 @@ test unixWm-44.1 {UpdateGeometryInfo procedure, width/height computation} unix { list [winfo width .t] [winfo height .t] } {180 20} test unixWm-44.2 {UpdateGeometryInfo procedure, width/height computation} unix { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 wm grid .t 5 4 10 12 wm geometry .t +30+40 @@ -1437,7 +1476,7 @@ test unixWm-44.2 {UpdateGeometryInfo procedure, width/height computation} unix { list [winfo width .t] [winfo height .t] } {130 36} test unixWm-44.3 {UpdateGeometryInfo procedure, width/height computation} unix { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 wm grid .t 5 4 10 12 wm geometry .t +30+40 @@ -1448,7 +1487,7 @@ test unixWm-44.3 {UpdateGeometryInfo procedure, width/height computation} unix { list [winfo width .t] [winfo height .t] } {40 132} test unixWm-44.4 {UpdateGeometryInfo procedure, width/height computation} unix { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 200 wm geometry .t +30+40 wm overrideredirect .t 1 @@ -1458,7 +1497,7 @@ test unixWm-44.4 {UpdateGeometryInfo procedure, width/height computation} unix { list [winfo width .t] [winfo height .t] } {300 150} test unixWm-44.5 {UpdateGeometryInfo procedure, negative width} unix { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 wm grid .t 18 7 10 12 wm geometry .t +30+40 @@ -1469,7 +1508,7 @@ test unixWm-44.5 {UpdateGeometryInfo procedure, negative width} unix { list [winfo width .t] [winfo height .t] } {1 72} test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} unix { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 wm grid .t 18 7 10 12 wm geometry .t +30+40 @@ -1480,7 +1519,7 @@ test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} unix { list [winfo width .t] [winfo height .t] } {100 1} -catch {destroy .t} +destroy .t toplevel .t -width 80 -height 60 test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} unix { wm geometry .t +5-10 @@ -1489,7 +1528,7 @@ test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} unix { list [winfo x .t] [winfo y .t] } [list 5 [expr [winfo screenheight .t] - 70]] -catch {destroy .t} +destroy .t toplevel .t -width 80 -height 60 test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} unix { wm geometry .t -30+2 @@ -1497,10 +1536,10 @@ test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} unix { tkwait visibility .t list [winfo x .t] [winfo y .t] } [list [expr [winfo screenwidth .t] - 110] 2] -catch {destroy .t} +destroy .t test unixWm-44.9 {UpdateGeometryInfo procedure, updating fixed dimensions} {unix testwrapper} { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 wm resizable .t 0 0 wm geometry .t +0+0 @@ -1512,7 +1551,7 @@ test unixWm-44.9 {UpdateGeometryInfo procedure, updating fixed dimensions} {unix [expr [lindex $property 7]] [expr [lindex $property 8]] } {180 20 180 20} test unixWm-44.10 {UpdateGeometryInfo procedure, menubar changing} testmenubar { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 wm resizable .t 0 0 wm geometry .t +0+0 @@ -1527,7 +1566,7 @@ test unixWm-44.10 {UpdateGeometryInfo procedure, menubar changing} testmenubar { } {{} {}} test unixWm-45.1 {UpdateSizeHints procedure, grid information} {unix testwrapper} { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 wm grid .t 6 10 10 5 wm minsize .t 2 4 @@ -1540,7 +1579,7 @@ test unixWm-45.1 {UpdateSizeHints procedure, grid information} {unix testwrapper [expr [lindex $property 9]] [expr [lindex $property 10]] } {40 30 320 210 10 5} test unixWm-45.2 {UpdateSizeHints procedure} {unix testwrapper} { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 wm minsize .t 30 40 wm maxsize .t 200 500 @@ -1552,7 +1591,7 @@ test unixWm-45.2 {UpdateSizeHints procedure} {unix testwrapper} { [expr [lindex $property 9]] [expr [lindex $property 10]] } {30 40 200 500 1 1} test unixWm-45.3 {UpdateSizeHints procedure, grid with menu} {testmenubar testwrapper} { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 frame .t.menu -height 23 -width 50 testmenubar window .t .t.menu @@ -1568,7 +1607,7 @@ test unixWm-45.3 {UpdateSizeHints procedure, grid with menu} {testmenubar testwr [expr [lindex $property 9]] [expr [lindex $property 10]] } {60 40 53 320 233 10 5} test unixWm-45.4 {UpdateSizeHints procedure, not resizable with menu} {testmenubar testwrapper} { - catch {destroy .t} + destroy .t toplevel .t -width 80 -height 60 frame .t.menu -height 23 -width 50 testmenubar window .t .t.menu @@ -1585,7 +1624,7 @@ test unixWm-45.4 {UpdateSizeHints procedure, not resizable with menu} {testmenub # I don't know how to test WaitForConfigureNotify. test unixWm-46.1 {WaitForEvent procedure, use of modal timeout} unix { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 200 wm geom .t +0+0 update @@ -1599,7 +1638,7 @@ test unixWm-46.1 {WaitForEvent procedure, use of modal timeout} unix { } {no yes} test unixWm-47.1 {WaitRestrictProc procedure} {unix nonPortable} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 frame .t.f -bd 2 -relief raised place .t.f -x 20 -y 30 -width 100 -height 20 @@ -1624,7 +1663,7 @@ test unixWm-47.1 {WaitRestrictProc procedure} {unix nonPortable} { # I don't know how to test WaitTimeoutProc, WaitForMapNotify, or UpdateHints. -catch {destroy .t} +destroy .t toplevel .t -width 300 -height 200 wm geometry .t +0+0 tkwait visibility .t @@ -1668,7 +1707,7 @@ test unixWm-48.12 {ParseGeometry procedure} unix { catch {wm geometry .t +30+-10} } {0} test unixWm-48.13 {ParseGeometry procedure, resize causes window to move} unix { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 200 wm geom .t +0+0 update @@ -1683,7 +1722,7 @@ test unixWm-48.13 {ParseGeometry procedure, resize causes window to move} unix { } {50 -100 150 300} test unixWm-49.1 {Tk_GetRootCoords procedure} unix { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 frame .t.f -width 150 -height 100 -bd 2 -relief raised place .t.f -x 150 -y 120 @@ -1695,7 +1734,7 @@ test unixWm-49.1 {Tk_GetRootCoords procedure} unix { list [winfo rootx .t.f.f] [winfo rooty .t.f.f] } {202 192} test unixWm-49.2 {Tk_GetRootCoords procedure, menubars} {unix testmenubar} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 update @@ -1785,7 +1824,7 @@ test unixWm-50.3 { cleanupbg } -result {{} .x .t .t.f} test unixWm-50.4 {Tk_CoordsToWindow procedure, window in other application} unix { - catch {destroy .t} + destroy .t catch {interp delete slave} toplevel .t -width 200 -height 200 -bg green wm geometry .t +0+0 @@ -1838,7 +1877,7 @@ test unixWm-50.6 {Tk_CoordsToWindow procedure, embedding within one app.} unix { [winfo containing [expr $x +250] [expr $y +80]] } {.t .t2 .t2 .t} test unixWm-50.7 {Tk_CoordsToWindow procedure, more basics} unix { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 400 -bg green wm geom .t +0+0 frame .t.f -width 100 -height 200 -bd 2 -relief raised @@ -1855,7 +1894,7 @@ test unixWm-50.7 {Tk_CoordsToWindow procedure, more basics} unix { [winfo containing $x [expr $y + 450]] } {.t .t.f .t.f.f .t {}} test unixWm-50.8 {Tk_CoordsToWindow procedure, more basics} unix { - catch {destroy .t} + destroy .t toplevel .t -width 400 -height 300 -bg green wm geom .t +0+0 frame .t.f -width 200 -height 100 -bd 2 -relief raised @@ -1872,8 +1911,8 @@ test unixWm-50.8 {Tk_CoordsToWindow procedure, more basics} unix { [winfo containing [expr $x + 450] $y] } {.t .t.f .t.f.f .t {}} test unixWm-50.9 {Tk_CoordsToWindow procedure, unmapped windows} unix { - catch {destroy .t} - catch {destroy .t2} + destroy .t + destroy .t2 sleep 500 ;# Give window manager time to catch up. toplevel .t -width 200 -height 200 -bg green wm geometry .t +0+0 @@ -1886,7 +1925,7 @@ test unixWm-50.9 {Tk_CoordsToWindow procedure, unmapped windows} unix { lappend result [winfo containing 100 100] } {.t2 .t} test unixWm-50.10 {Tk_CoordsToWindow procedure, unmapped windows} unix { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 200 -bg green wm geometry .t +0+0 frame .t.f -width 150 -height 150 -bd 2 -relief raised @@ -1956,18 +1995,18 @@ test unixWm-51.5 {TkWmRestackToplevel procedure, basic tests} {unix nonPortable} } {.raise1 .raise3} deleteWindows test unixWm-51.6 {TkWmRestackToplevel procedure, window to be stacked isn't mapped} unix { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 200 -bg green wm geometry .t +0+0 tkwait visibility .t - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 200 -height 200 -bg red wm geometry .t2 +0+0 winfo containing 100 100 } {.t} test unixWm-51.7 {TkWmRestackToplevel procedure, other window isn't mapped} unix { foreach w {.t .t2 .t3} { - catch {destroy $w} + destroy $w toplevel $w -width 200 -height 200 -bg green wm geometry $w +0+0 } @@ -1980,12 +2019,12 @@ test unixWm-51.7 {TkWmRestackToplevel procedure, other window isn't mapped} unix lappend result [winfo containing 100 100] } {.t3 .t} test unixWm-51.8 {TkWmRestackToplevel procedure, overrideredirect windows} unix { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 200 -bg green wm overrideredirect .t 1 wm geometry .t +0+0 tkwait visibility .t - catch {destroy .t2} + destroy .t2 toplevel .t2 -width 200 -height 200 -bg red wm overrideredirect .t2 1 wm geometry .t2 +0+0 @@ -2006,7 +2045,7 @@ test unixWm-51.8 {TkWmRestackToplevel procedure, overrideredirect windows} unix } {.t2 .t .t2} test unixWm-51.9 {TkWmRestackToplevel procedure, other window overrideredirect} unix { foreach w {.t .t2 .t3} { - catch {destroy $w} + destroy $w toplevel $w -width 200 -height 200 -bg green wm overrideredirect $w 1 wm geometry $w +0+0 @@ -2049,14 +2088,14 @@ test unixWm-51.13 {TkWmRestackToplevel procedure, don't move window that's alrea } 1 test unixWm-52.1 {TkWmAddToColormapWindows procedure} unix { - catch {destroy .t} + destroy .t toplevel .t -width 200 -height 200 -colormap new -relief raised -bd 2 wm geom .t +0+0 update wm colormap .t } {} test unixWm-52.2 {TkWmAddToColormapWindows procedure} unix { - catch {destroy .t} + destroy .t toplevel .t -colormap new -relief raised -bd 2 wm geom .t +0+0 frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 @@ -2065,7 +2104,7 @@ test unixWm-52.2 {TkWmAddToColormapWindows procedure} unix { wm colormap .t } {.t.f .t} test unixWm-52.3 {TkWmAddToColormapWindows procedure} unix { - catch {destroy .t} + destroy .t toplevel .t -colormap new wm geom .t +0+0 frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 @@ -2076,7 +2115,7 @@ test unixWm-52.3 {TkWmAddToColormapWindows procedure} unix { wm colormap .t } {.t.f .t.f2 .t} test unixWm-52.4 {TkWmAddToColormapWindows procedure} unix { - catch {destroy .t} + destroy .t toplevel .t -colormap new wm geom .t +0+0 frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 @@ -2090,7 +2129,7 @@ test unixWm-52.4 {TkWmAddToColormapWindows procedure} unix { } {.t.f} test unixWm-53.1 {TkWmRemoveFromColormapWindows procedure} unix { - catch {destroy .t} + destroy .t toplevel .t -colormap new wm geom .t +0+0 frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 @@ -2102,7 +2141,7 @@ test unixWm-53.1 {TkWmRemoveFromColormapWindows procedure} unix { wm colormap .t } {.t.f .t} test unixWm-53.2 {TkWmRemoveFromColormapWindows procedure} unix { - catch {destroy .t} + destroy .t toplevel .t -colormap new wm geom .t +0+0 frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 @@ -2115,9 +2154,9 @@ test unixWm-53.2 {TkWmRemoveFromColormapWindows procedure} unix { wm colormap .t } {} -test unixWm-54.1 {TkpMakeMenuWindow procedure, setting save_under} unix { - catch {destroy .t} - catch {destroy .m} +test unixWm-54.1 {TkpMakeMenuWindow procedure, setting save_under} {unix nonUnixUserInteraction} { + destroy .t + destroy .m toplevel .t -width 300 -height 200 -bd 2 -relief raised bind .t <Expose> {set x exposed} wm geom .t +0+0 @@ -2132,8 +2171,8 @@ test unixWm-54.1 {TkpMakeMenuWindow procedure, setting save_under} unix { destroy .m set x } {no event} -test unixWm-54.2 {TkpMakeMenuWindow procedure, setting override_redirect} unix { - catch {destroy .m} +test unixWm-54.2 {TkpMakeMenuWindow procedure, setting override_redirect} {unix nonUnixUserInteraction} { + destroy .m menu .m .m add command -label First .m add command -label Second @@ -2148,7 +2187,7 @@ test unixWm-54.2 {TkpMakeMenuWindow procedure, setting override_redirect} unix { # No tests for TkGetPointerCoords, CreateWrapper, or GetMaxSize. test unixWm-55.1 {TkUnixSetMenubar procedure} {unix testmenubar} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 update @@ -2160,8 +2199,8 @@ test unixWm-55.1 {TkUnixSetMenubar procedure} {unix testmenubar} { [expr [winfo rooty .t] - [winfo rooty .t.f]] } {1 300x30+0+0 0 30} test unixWm-55.2 {TkUnixSetMenubar procedure, removing menubar} {unix testmenubar} { - catch {destroy .t} - catch {destroy .f} + destroy .t + destroy .f toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 update @@ -2179,7 +2218,7 @@ test unixWm-55.2 {TkUnixSetMenubar procedure, removing menubar} {unix testmenuba [expr [winfo rooty .] - [winfo rooty .f]] } {0 300x30+0+0 0 0 0 0} test unixWm-55.3 {TkUnixSetMenubar procedure, removing geometry manager} {unix testmenubar} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 update @@ -2196,7 +2235,7 @@ test unixWm-55.3 {TkUnixSetMenubar procedure, removing geometry manager} {unix t lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y] } {0 0 0 0} test unixWm-55.4 {TkUnixSetMenubar procedure, toplevel not yet created} {unix testmenubar} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 -bd 2 -relief raised frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green testmenubar window .t .t.f @@ -2207,8 +2246,8 @@ test unixWm-55.4 {TkUnixSetMenubar procedure, toplevel not yet created} {unix te [expr [winfo rooty .t] - [winfo rooty .t.f]] } {1 300x30+0+0 0 30} test unixWm-55.5 {TkUnixSetMenubar procedure, changing menubar} {unix testmenubar} { - catch {destroy .t} - catch {destroy .f} + destroy .t + destroy .f toplevel .t -width 300 -height 200 -bd 2 -relief raised frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green wm geom .t +0+0 @@ -2226,7 +2265,7 @@ test unixWm-55.5 {TkUnixSetMenubar procedure, changing menubar} {unix testmenuba lappend result [expr [winfo rooty .f] - $y] } {0 1 0 1 0 0} test unixWm-55.6 {TkUnixSetMenubar procedure, changing menubar to self} {unix testmenubar} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 -bd 2 -relief raised frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green testmenubar window .t .t.f @@ -2239,8 +2278,8 @@ test unixWm-55.6 {TkUnixSetMenubar procedure, changing menubar to self} {unix te [expr [winfo rooty .t] - [winfo rooty .t.f]] } {1 300x30+0+0 0 30} test unixWm-55.7 {TkUnixSetMenubar procedure, unsetting event handler} {unix testmenubar} { - catch {destroy .t} - catch {destroy .f} + destroy .t + destroy .f toplevel .t -width 300 -height 200 -bd 2 -relief raised frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green frame .f -width 400 -height 40 -bd 2 -relief raised -bg blue @@ -2259,7 +2298,7 @@ test unixWm-55.7 {TkUnixSetMenubar procedure, unsetting event handler} {unix tes } {30 40 40} test unixWm-56.1 {MenubarDestroyProc procedure} {unix testmenubar} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 update @@ -2274,7 +2313,7 @@ test unixWm-56.1 {MenubarDestroyProc procedure} {unix testmenubar} { } {30 0} test unixWm-57.1 {MenubarReqProc procedure} {unix testmenubar} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 update @@ -2289,7 +2328,7 @@ test unixWm-57.1 {MenubarReqProc procedure} {unix testmenubar} { lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y] } {0 10 0 100} test unixWm-57.2 {MenubarReqProc procedure} {unix testmenubar} { - catch {destroy .t} + destroy .t toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 update @@ -2305,7 +2344,7 @@ test unixWm-57.2 {MenubarReqProc procedure} {unix testmenubar} { } {0 20 0 1} test unixWm-58.1 {UpdateCommand procedure, DString gets reallocated} {unix testwrapper} { - catch {destroy .t} + destroy .t toplevel .t -width 100 -height 50 wm geom .t +0+0 wm command .t "argumentNumber0 argumentNumber1 argumentNumber2 argumentNumber0 argumentNumber3 argumentNumber4 argumentNumber5 argumentNumber6 argumentNumber0 argumentNumber7 argumentNumber8 argumentNumber9 argumentNumber10 argumentNumber0 argumentNumber11 argumentNumber12 argumentNumber13 argumentNumber14 argumentNumber15 argumentNumber16 argumentNumber17 argumentNumber18" @@ -2351,14 +2390,16 @@ test unixWm-59.1 {exit processing} unix { list $error $msg } {0 {}} test unixWm-59.2 {exit processing} unix { - set script [makeFile { + set code [loadTkCommand] + append code { interp create x x eval {set argc 2} x eval {set argv "-geometry 10x10+0+0"} x eval {load {} Tk} update exit - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -2368,7 +2409,8 @@ test unixWm-59.2 {exit processing} unix { list $error $msg } {0 {}} test unixWm-59.3 {exit processing} unix { - set script [makeFile { + set code [loadTkCommand] + append code { interp create x x eval {set argc 2} x eval {set argv "-geometry 10x10+0+0"} @@ -2381,7 +2423,8 @@ test unixWm-59.3 {exit processing} unix { proc destroy_x {} {interp delete x} update exit - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -2391,16 +2434,42 @@ test unixWm-59.3 {exit processing} unix { list $error $msg } {0 {}} -test unixWm-60.1 {wm attributes} unix { +# +# wm attributes tests: +# +# NOTE: since [wm attributes] is not guaranteed to have any effect, +# the only thing we can really test here is the syntax. +# +test unixWm-60.1 {wm attributes - test} -constraints unix -body { destroy .t toplevel .t wm attributes .t -} {-type {}} -test unixWm-60.2 {wm attributes} unix { +} -result [list -alpha 1.0 -topmost 0 -zoomed 0 -fullscreen 0 -type {}] + +test unixWm-60.2 {wm attributes - test} -constraints unix -body { + destroy .t + toplevel .t + wm attributes .t -topmost +} -result 0 + +test unixWm-60.3 {wm attributes - set (unrealized)} -constraints unix -body { destroy .t toplevel .t - list [catch {wm attributes .t -foo} msg] $msg -} {1 {wrong # args: should be "wm attributes window ?-type list?"}} + wm attributes .t -topmost 1 +} + +test unixWm-60.4 {wm attributes - set (realized)} -constraints unix -body { + destroy .t + toplevel .t + tkwait visibility .t + wm attributes .t -topmost 1 +} + +test unixWm-60.5 {wm attributes - bad attribute} -constraints unix -body { + destroy .t + toplevel .t + wm attributes .t -foo +} -returnCodes 1 -match glob -result {bad attribute "-foo":*} test unixWm-61.1 {Tk_WmCmd procedure, "iconphoto" option} unix { list [catch {wm iconph .} msg] $msg @@ -2415,45 +2484,54 @@ test unixWm-61.2 {Tk_WmCmd procedure, "iconphoto" option} unix { image delete blank16 blank32 } {} -test unixWm-62.0 {wm attributes -type void} unix { +test unixWm-62.0 {wm attributes -type void} -constraints unix -setup { destroy .t toplevel .t - set r [list [catch {wm attributes .t -type {}} err] $err] +} -body { + wm attributes .t -type {} +} -cleanup { destroy .t - set r -} {0 {}} -test unixWm-62.1 {wm attributes -type name} unix { +} -result {} + +test unixWm-62.1 {wm attributes -type name} -constraints unix -setup { destroy .t toplevel .t - set r [list [catch {wm attributes .t -type dialog} err] $err] +} -body { + wm attributes .t -type dialog +} -cleanup { destroy .t - set r -} {0 {}} -test unixWm-62.1 {wm attributes -type name} unix { +} -result {} + +test unixWm-62.2 {wm attributes -type name} -constraints unix -setup { destroy .t toplevel .t +} -body { tkwait visibility .t - set r [list [catch {wm attributes .t -type dialog} err] $err] + wm attributes .t -type dialog +} -cleanup { destroy .t - set r -} {0 {}} -test unixWm-62.2 {wm attributes -type list} unix { +} -result {} + +test unixWm-62.3 {wm attributes -type list} -constraints unix -setup { destroy .t toplevel .t - set r [list [catch {wm attributes .t -type {xyzzy dialog}} err] $err] +} -body { + wm attributes .t -type {xyzzy dialog} +} -cleanup { destroy .t - set r -} {0 {}} -test unixWm-62.2 {wm attributes -type list} unix { +} -result {} + +test unixWm-62.4 {wm attributes -type list} -constraints unix -setup { destroy .t toplevel .t +} -body { tkwait visibility .t - set r [list [catch {wm attributes .t -type {xyzzy dialog}} err] $err] + wm attributes .t -type {xyzzy dialog} +} -cleanup { destroy .t - set r -} {0 {}} +} -result {} # cleanup -catch {destroy .t} -::tcltest::cleanupTests +destroy .t +cleanupTests return diff --git a/tests/util.test b/tests/util.test index 66ce26f..86271c5 100644 --- a/tests/util.test +++ b/tests/util.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands listbox .l -width 20 -height 5 -relief sunken -bd 2 @@ -65,18 +62,5 @@ test util-1.12 {Tk_GetScrollInfo procedure} { } {1 {unknown option "dropdead": must be moveto or scroll}} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/visual.test b/tests/visual.test index 3f56e21..1006e18 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -8,10 +8,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands update @@ -70,43 +67,43 @@ if {[llength $avail] > 1} { } } } +testConstraint haveOtherVisual [expr {$other ne ""}] +testConstraint havePseudocolorVisual [string match *pseudocolor* $avail] +testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}] 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 @@ -164,7 +161,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} @@ -174,95 +171,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 {[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 {[testConstraint defaultPseudocolor8]} { catch {destroy .t1} catch {destroy .t2} } @@ -280,39 +275,24 @@ 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 {} rename colorsFree {} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - - diff --git a/tests/visual_bb.test b/tests/visual_bb.test index 8bab7e4..6b10f76 100644 --- a/tests/visual_bb.test +++ b/tests/visual_bb.test @@ -7,14 +7,9 @@ # are kept in separate ".tcl" files in this directory. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::cleanupTests - set auto_path ". $auto_path" wm title . "Visual Tests for Tk" diff --git a/tests/winButton.test b/tests/winButton.test index 204bc67..5bf6867 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -9,10 +9,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands proc bogusTrace args { @@ -32,14 +29,14 @@ radiobutton .r -text Radiobutton pack .l .b .c .r update -test winbutton-1.1 {TkpComputeButtonGeometry procedure} {testImageType pcOnly} { +test winbutton-1.1 {TkpComputeButtonGeometry procedure} {testImageType win} { deleteWindows image create test image1 image1 changed 0 0 0 0 60 40 label .b1 -image image1 -bd 4 -padx 0 -pady 2 button .b2 -image image1 -bd 4 -padx 0 -pady 2 - checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1 - radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0 + checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1 -font {{MS Sans Serif} 8} + radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0 -font {{MS Sans Serif} 8} pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: @@ -49,12 +46,12 @@ test winbutton-1.1 {TkpComputeButtonGeometry procedure} {testImageType pcOnly} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {68 48 70 50 90 52 90 52} -test winbutton-1.2 {TkpComputeButtonGeometry procedure} {pcOnly} { +test winbutton-1.2 {TkpComputeButtonGeometry procedure} win { deleteWindows label .b1 -bitmap question -bd 3 -padx 0 -pady 2 button .b2 -bitmap question -bd 3 -padx 0 -pady 2 - checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 - radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0 + checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 -font {{MS Sans Serif} 8} + radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0 -font {{MS Sans Serif} 8} pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: @@ -64,7 +61,7 @@ test winbutton-1.2 {TkpComputeButtonGeometry procedure} {pcOnly} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {23 33 25 35 45 37 45 37} -test winbutton-1.3 {TkpComputeButtonGeometry procedure} {pcOnly} { +test winbutton-1.3 {TkpComputeButtonGeometry procedure} win { deleteWindows label .b1 -bitmap question -bd 3 -highlightthickness 4 button .b2 -bitmap question -bd 3 -highlightthickness 0 @@ -80,7 +77,7 @@ test winbutton-1.3 {TkpComputeButtonGeometry procedure} {pcOnly} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {31 41 23 33 27 37 27 37} -test winbutton-1.4 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { +test winbutton-1.4 {TkpComputeButtonGeometry procedure} {win nonPortable} { deleteWindows label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} @@ -93,21 +90,21 @@ test winbutton-1.4 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {58 24 67 33 88 30 90 28} -test winbutton-1.5 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { +test winbutton-1.5 {TkpComputeButtonGeometry procedure} {win nonPortable} { deleteWindows label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } {178 84} -test winbutton-1.6 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { +test winbutton-1.6 {TkpComputeButtonGeometry procedure} {win nonPortable} { deleteWindows label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } {222 52} -test winbutton-1.7 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { +test winbutton-1.7 {TkpComputeButtonGeometry procedure} {win nonPortable} { deleteWindows label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 @@ -120,7 +117,7 @@ test winbutton-1.7 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {74 24 67 97 174 46 64 28} -test winbutton-1.8 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { +test winbutton-1.8 {TkpComputeButtonGeometry procedure} {win nonPortable} { deleteWindows label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ -highlightthickness 4 @@ -136,7 +133,7 @@ test winbutton-1.8 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {66 32 65 31 69 31 71 29} -test winbutton-1.9 {TkpComputeButtonGeometry procedure} {pcOnly} { +test winbutton-1.9 {TkpComputeButtonGeometry procedure} win { deleteWindows button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] @@ -144,5 +141,5 @@ test winbutton-1.9 {TkpComputeButtonGeometry procedure} {pcOnly} { # cleanup deleteWindows -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/winClipboard.test b/tests/winClipboard.test index cc401c6..ec84362 100644 --- a/tests/winClipboard.test +++ b/tests/winClipboard.test @@ -11,32 +11,25 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::bytestring - # Note that these tests may fail if another application is grabbing the # clipboard (e.g. an X server) -testConstraint testclipboard [llength [info commands testclipboard]] - -test winClipboard-1.1 {TkSelGetSelection} {pcOnly} { +test winClipboard-1.1 {TkSelGetSelection} win { clipboard clear catch {selection get -selection CLIPBOARD} msg set msg } {CLIPBOARD selection doesn't exist or form "STRING" not defined} -test winClipboard-1.2 {TkSelGetSelection} {pcOnly testclipboard} { +test winClipboard-1.2 {TkSelGetSelection} {win testclipboard} { clipboard clear clipboard append {} catch {selection get -selection CLIPBOARD} r1 catch {testclipboard} r2 list $r1 $r2 } {{} {}} -test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} {pcOnly testclipboard} { +test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} {win testclipboard} { clipboard clear clipboard append abcd update @@ -44,14 +37,14 @@ test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} {pcOnly testcli catch {testclipboard} r2 list $r1 $r2 } {abcd abcd} -test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} {pcOnly testclipboard} { +test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} {win testclipboard} { clipboard clear clipboard append "line 1\nline 2" catch {selection get -selection CLIPBOARD} r1 catch {testclipboard} r2 list $r1 $r2 } [list "line 1\nline 2" "line 1\r\nline 2"] -test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} {pcOnly testclipboard} { +test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} {win testclipboard} { clipboard clear clipboard append "line 1\u00c7\nline 2" catch {selection get -selection CLIPBOARD} r1 @@ -59,7 +52,7 @@ test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} {pcOnly testcli list $r1 $r2 } [list "line 1\u00c7\nline 2" [bytestring "line 1\u00c7\r\nline 2"]] -test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} {pcOnly testclipboard} { +test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} {win testclipboard} { clipboard clear clipboard append -type OUR_ACTION "action data" clipboard append "string data" @@ -68,7 +61,7 @@ test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} {pcOnly testclip catch {testclipboard} r2 list $r1 $r2 } [list "action data" "string data"] -test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} {pcOnly testclipboard} { +test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} {win testclipboard} { clipboard clear clipboard append -type OUR_ACTION "new data" clipboard append "more data in string" @@ -79,5 +72,5 @@ test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} {pcOnly testclip } [list "more data in string" "new data"] # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/winDialog.test b/tests/winDialog.test index e7d175f..d340aee 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -1,3 +1,4 @@ +# -*- tcl -*- # This file is a Tcl script to test the Windows specific behavior of # the common dialog boxes. It is organized in the standard # fashion for Tcl tests. @@ -7,15 +8,18 @@ # Copyright (c) 1998-1999 ActiveState Corporation. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint testwinevent [llength [info commands testwinevent]] +if {[testConstraint testwinevent]} { + catch {testwinevent debug 1} +} -catch {testwinevent debug 1} +# Locale identifier LANG_ENGLISH is 0x09 +testConstraint english [expr { + [llength [info commands testwinlocale]] + && (([testwinlocale] & 0xff) == 9) +}] proc start {arg} { set ::tk_dialog 0 @@ -46,38 +50,122 @@ proc afterbody {} { } proc Click {button} { + switch -exact -- $button { + ok { set button 1 } + cancel { set button 2 } + } testwinevent $::tk_dialog $button WM_LBUTTONDOWN 1 0x000a000b testwinevent $::tk_dialog $button WM_LBUTTONUP 0 0x000a000b } -proc GetText {button} { - return [testwinevent $::tk_dialog $button WM_GETTEXT] +proc GetText {id} { + switch -exact -- $id { + ok { set id 1 } + cancel { set id 2 } + } + return [testwinevent $::tk_dialog $id WM_GETTEXT] } -proc SetText {button text} { - return [testwinevent $::tk_dialog $button WM_SETTEXT $text] +proc SetText {id text} { + return [testwinevent $::tk_dialog $id WM_SETTEXT $text] } -test winDialog-1.1 {Tk_ChooseColorObjCmd} {nt} { -} {} - -test winDialog-2.1 {ColorDlgHookProc} {nt} { +test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints { + testwinevent +} -body { + start {tk_chooseColor} + then { + Click cancel + } +} -result {0} +test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints { + testwinevent +} -body { + start {set clr [tk_chooseColor -initialcolor "#ff9933"]} + then { + set x [Click cancel] + } + list $x $clr +} -result {0 {}} +test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints { + testwinevent +} -body { + start {set clr [tk_chooseColor -initialcolor "#ff9933"]} + then { + set x [Click ok] + } + list $x $clr +} -result [list 0 "#ff9933"] +test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints { + testwinevent +} -setup {unset -nocomplain a x} -body { + set x {} + start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]} + then { + if {[catch { + array set a [testgetwindowinfo $::tk_dialog] + if {[info exists a(text)]} {lappend x $a(text)} + } err]} { lappend x $err } + lappend x [Click ok] + } + lappend x $clr +} -result [list Hello 0 "#ff9933"] +test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints { + testwinevent +} -setup {unset -nocomplain a x} -body { + set x {} + start { + set clr [tk_chooseColor -initialcolor "#ff9933" \ + -title "\u041f\u0440\u0438\u0432\u0435\u0442"] + } + then { + if {[catch { + array set a [testgetwindowinfo $::tk_dialog] + if {[info exists a(text)]} {lappend x $a(text)} + } err]} { lappend x $err } + lappend x [Click ok] + } + lappend x $clr +} -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"] +test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints { + testwinevent +} -setup {unset -nocomplain a x} -body { + start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]} + set x {} + then { + if {[catch { + array set a [testgetwindowinfo $::tk_dialog] + if {[info exists a(parent)]} { + append x [expr {$a(parent) == [wm frame .]}] + } + } err]} {lappend x $err} + Click ok + } + list $x $clr +} -result [list 1 "#ff9933"] +test winDialog-1.1.6 {Tk_ChooseColorObjCmd: -parent} -constraints { + testwinevent +} -body { + tk_chooseColor -initialcolor "#ff9933" -parent .xyzzy12 +} -returnCodes error -match glob -result {bad window path name*} + +test winDialog-2.1 {ColorDlgHookProc} {emptyTest nt} { } {} -test winDialog-3.1 {Tk_GetOpenFileObjCmd} {nt testwinevent} { +test winDialog-3.1 {Tk_GetOpenFileObjCmd} {nt testwinevent english} { start {tk_getOpenFile} then { - set x [GetText 2] - Click 2 + set x [GetText cancel] + Click cancel } set x } {Cancel} -test winDialog-4.1 {Tk_GetSaveFileObjCmd} {nt testwinevent} { +test winDialog-4.1 {Tk_GetSaveFileObjCmd} {nt testwinevent english} { start {tk_getSaveFile} then { - set x [GetText 2] - Click 2 + set x [GetText cancel] + Click cancel } set x } {Cancel} @@ -90,7 +178,7 @@ test winDialog-5.1 {GetFileName: no arguments} {nt testwinevent} { } {0} test winDialog-5.2 {GetFileName: one argument} {nt} { list [catch {tk_getOpenFile -foo} msg] $msg -} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, or -title}} +} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} test winDialog-5.4 {GetFileName: many arguments} {nt testwinevent} { start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo} then { @@ -99,7 +187,7 @@ test winDialog-5.4 {GetFileName: many arguments} {nt testwinevent} { } {0} test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} {nt} { list [catch {tk_getOpenFile -foo bar -abc} msg] $msg -} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, or -title}} +} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} test winDialog-5.6 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} { start {tk_getOpenFile -title bar} then { @@ -117,7 +205,7 @@ test winDialog-5.8 {GetFileName: extension begins with .} {nt testwinevent} { start {set x [tk_getSaveFile -defaultextension .foo -title Save]} then { SetText 0x480 bar - Click 1 + Click ok } string totitle $x } [string totitle [file join [pwd] bar.foo]] @@ -125,7 +213,7 @@ test winDialog-5.9 {GetFileName: extension doesn't begin with .} {nt testwineven start {set x [tk_getSaveFile -defaultextension foo -title Save]} then { SetText 0x480 bar - Click 1 + Click ok } string totitle $x } [string totitle [file join [pwd] bar.foo]] @@ -144,15 +232,19 @@ test winDialog-5.11 {GetFileName: file types: MakeFilter() fails} {nt} { list [catch {tk_getSaveFile -filetypes {{"foo" .foo FOO}}} msg] $msg } {1 {bad Macintosh file type "FOO"}} +if {[info exists ::env(TEMP)]} { test winDialog-5.12 {GetFileName: initial directory} {nt testwinevent} { # case FILE_INITDIR: - start {set x [tk_getSaveFile -initialdir c:/ -initialfile "12x 455" -title Foo]} + start {set x [tk_getSaveFile \ + -initialdir [file normalize $::env(TEMP)] \ + -initialfile "12x 455" -title Foo]} then { - Click 1 + Click ok } set x -} {C:/12x 455} +} [file join [file normalize $::env(TEMP)] "12x 455"] +} test winDialog-5.13 {GetFileName: initial directory: Tcl_TranslateFilename()} \ {nt} { # if (Tcl_TranslateFileName(interp, string, &ds) == NULL) @@ -164,7 +256,7 @@ test winDialog-5.14 {GetFileName: initial file} {nt testwinevent} { start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} then { - Click 1 + Click ok } string totitle $x } [string totitle [file join [pwd] "12x 456"]] @@ -172,18 +264,17 @@ test winDialog-5.15 {GetFileName: initial file: Tcl_TranslateFileName()} {nt} { # if (Tcl_TranslateFileName(interp, string, &ds) == NULL) list [catch {tk_getOpenFile -initialfile ~12x/455} msg] $msg } {1 {user "12x" doesn't exist}} -set a aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -append a $a -append a $a -append a $a -append a $a test winDialog-5.16 {GetFileName: initial file: long name} {nt testwinevent} { - start {set x [tk_getSaveFile -initialfile $a -title Long]} + start { + set dialogresult [catch { + tk_getSaveFile -initialfile [string repeat a 1024] -title Long + } x] + } then { - Click 1 + Click ok } - string totitle $x -} [string totitle [string range [file join [pwd] $a] 0 257]] + list $dialogresult [string match "invalid filename *" $x] +} {1 1} test winDialog-5.17 {GetFileName: parent} {nt} { # case FILE_PARENT: @@ -200,7 +291,7 @@ test winDialog-5.18 {GetFileName: title} {nt testwinevent} { start {tk_getOpenFile -title Narf} then { - Click 2 + Click cancel } } {0} test winDialog-5.19 {GetFileName: no filter specified} {nt testwinevent} { @@ -209,7 +300,7 @@ test winDialog-5.19 {GetFileName: no filter specified} {nt testwinevent} { start {tk_getOpenFile -title Filter} then { set x [GetText 0x470] - Click 2 + Click cancel } set x } {All Files (*.*)} @@ -230,34 +321,55 @@ test winDialog-5.21 {GetFileName: parent HWND already exists} {nt} { destroy .t } } {} -test winDialog-5.22 {GetFileName: call GetOpenFileName} {nt testwinevent} { +test winDialog-5.22 {GetFileName: call GetOpenFileName} {nt testwinevent english} { # winCode = GetOpenFileName(&ofn); start {tk_getOpenFile -title Open} then { - set x [GetText 1] - Click 2 + set x [GetText ok] + Click cancel } set x } {&Open} -test winDialog-5.23 {GetFileName: call GetSaveFileName} {nt testwinevent} { +test winDialog-5.23 {GetFileName: call GetSaveFileName} {nt testwinevent english} { # winCode = GetSaveFileName(&ofn); start {tk_getSaveFile -title Save} then { - set x [GetText 1] - Click 2 + set x [GetText ok] + Click cancel } set x } {&Save} +if {[info exists ::env(TEMP)]} { test winDialog-5.24 {GetFileName: convert \ to /} {nt testwinevent} { start {set x [tk_getSaveFile -title Back]} then { - SetText 0x480 "c:\\12x 457" - Click 1 + SetText 0x480 [file nativename \ + [file join [file normalize $::env(TEMP)] "12x 457"]] + Click ok } set x -} {c:/12x 457} +} [file join [file normalize $::env(TEMP)] "12x 457"] +} +test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} {nt} { + # MacOS type that is correct, but has embedded nulls. + + start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]} + then { + Click cancel + } + set x +} {0} +test winDialog-5.26 {GetFileName: file types: MakeFilter() succeeds} {nt} { + # MacOS type that is correct, but has embedded high-bit chars. + + start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]} + then { + Click cancel + } + set x +} {0} test winDialog-6.1 {MakeFilter} {emptyTest nt} {} {} @@ -306,7 +418,7 @@ test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} {nt testwinevent} { start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]} then { - Click 1 + Click ok } string tolower [set x] } {c:/} @@ -318,8 +430,10 @@ test winDialog-9.8 {Tk_ChooseDirectoryObjCmd:\ list [catch {tk_chooseDirectory -initialdir ~12x/455} msg] $msg } {1 {user "12x" doesn't exist}} -catch {testwinevent debug 0} +if {[testConstraint testwinevent]} { + catch {testwinevent debug 0} +} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/winFont.test b/tests/winFont.test index 299bc7e..c61d124 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -11,10 +11,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands catch {destroy .b} @@ -42,10 +39,10 @@ proc getsize {} { return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" } -test winfont-1.1 {TkpGetNativeFont procedure: not native} {pcOnly} { +test winfont-1.1 {TkpGetNativeFont procedure: not native} win { list [catch {font measure {} xyz} msg] $msg } {1 {font "" doesn't exist}} -test winfont-1.2 {TkpGetNativeFont procedure: native} {pcOnly} { +test winfont-1.2 {TkpGetNativeFont procedure: native} win { font measure ansifixed 0 font measure ansi 0 font measure device 0 @@ -55,99 +52,99 @@ test winfont-1.2 {TkpGetNativeFont procedure: native} {pcOnly} { set x {} } {} -test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} {pcOnly} { +test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} win { expr [font actual {-size -10} -size]>0 } {1} -test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} {pcOnly} { +test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} win { expr [font actual {-family Arial} -size]>0 } {1} -test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} {pcOnly} { +test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} win { font actual {-weight normal} -weight } {normal} -test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} {pcOnly} { +test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} win { font actual {-weight bold} -weight } {bold} -test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} {pcOnly} { +test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} win { catch {expr {[font actual {-size 10} -size]}} } 0 -test winfont-2.6 {TkpGetFontFromAttributes procedure: family} {pcOnly} { +test winfont-2.6 {TkpGetFontFromAttributes procedure: family} win { font actual {-family Arial} -family } {Arial} -test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} {pcOnly} { +test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} win { set x {} lappend x [font actual {-family "Times"} -family] lappend x [font actual {-family "New York"} -family] lappend x [font actual {-family "Times New Roman"} -family] } {{Times New Roman} {Times New Roman} {Times New Roman}} -test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} {pcOnly} { +test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} win { set x {} lappend x [font actual {-family "Courier"} -family] lappend x [font actual {-family "Monaco"} -family] lappend x [font actual {-family "Courier New"} -family] } {{Courier New} {Courier New} {Courier New}} -test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} {pcOnly} { +test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} win { set x {} lappend x [font actual {-family "Helvetica"} -family] lappend x [font actual {-family "Geneva"} -family] lappend x [font actual {-family "Arial"} -family] } {Arial Arial Arial} -test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} {pcOnly} { +test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} win { # No way to get it to fail! Any font name is acceptable. } {} -test winfont-3.1 {TkpDeleteFont procedure} {pcOnly} { +test winfont-3.1 {TkpDeleteFont procedure} win { font actual {-family xyz} set x {} } {} -test winfont-4.1 {TkpGetFontFamilies procedure} {pcOnly} { +test winfont-4.1 {TkpGetFontFamilies procedure} win { font families set x {} } {} -test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} {pcOnly} { +test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} win { .b.l config -wrap 0 -text "000000" getsize } "[expr $ax*6] $ay" -test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} {pcOnly} { +test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} win { .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" getsize } "[expr $ax*256] $ay" -test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} {pcOnly} { +test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} win { .b.l config -wrap [expr $ax*10] -text "00000000" getsize } "[expr $ax*8] $ay" -test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} {pcOnly} { +test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} win { .b.l config -wrap [expr $ax*6] -text "00000000" getsize } "[expr $ax*6] [expr $ay*2]" -test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} {pcOnly} { +test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} win { .b.c dchars $t 0 end .b.c insert $t 0 "0000" .b.c index $t @[expr int($cx*2.5)],1 } {2} -test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} {pcOnly} { +test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} win { .b.l config -text "000000" -wrap 1 getsize } "$ax [expr $ay*6]" -test winfont-5.7 {Tk_MeasureChars procedure: whole words} {pcOnly} { +test winfont-5.7 {Tk_MeasureChars procedure: whole words} win { .b.l config -wrap [expr $ax*8] -text "000000 0000" getsize } "[expr $ax*6] [expr $ay*2]" -test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} {pcOnly} { +test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} win { .b.l config -wrap [expr $ax*12] -text "000000 0000000" getsize } "[expr $ax*7] [expr $ay*2]" -test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} {pcOnly} { +test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} win { .b.l config -wrap [expr $ax*12] -text "000 00 00000" getsize } "[expr $ax*7] [expr $ay*2]" -test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} {pcOnly} { +test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} win { .b.l config -wrap [expr $ax*12] -text "0000000000000000" getsize } "[expr $ax*12] [expr $ay*2]" -test winfont-5.10 {Tk_MeasureChars procedure: check for kerning} \ - {pcOnly nonPortable} { +test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} \ + {win nonPortable} { set font [.b.l cget -font] .b.l config -font {{MS Sans Serif} 8} -text "W" set width [winfo reqwidth .b.l] @@ -156,12 +153,13 @@ test winfont-5.10 {Tk_MeasureChars procedure: check for kerning} \ .b.l config -font $font expr $x < ($width*10) } 1 -test winfont-6.1 {Tk_DrawChars procedure: loop test} {pcOnly} { + +test winfont-6.1 {Tk_DrawChars procedure: loop test} win { .b.l config -text "a" update } {} -test winfont-7.1 {AllocFont procedure: use old font} {pcOnly} { +test winfont-7.1 {AllocFont procedure: use old font} win { font create xyz catch {destroy .c} button .c -font xyz @@ -170,17 +168,17 @@ test winfont-7.1 {AllocFont procedure: use old font} {pcOnly} { destroy .c font delete xyz } {} -test winfont-7.2 {AllocFont procedure: extract info from logfont} {pcOnly} { +test winfont-7.2 {AllocFont procedure: extract info from logfont} win { font actual {arial 10 bold italic underline overstrike} } {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1} -test winfont-7.3 {AllocFont procedure: extract info from textmetric} {pcOnly} { +test winfont-7.3 {AllocFont procedure: extract info from textmetric} win { font metric {arial 10 bold italic underline overstrike} -fixed } {0} -test winfont-7.4 {AllocFont procedure: extract info from textmetric} {pcOnly} { +test winfont-7.4 {AllocFont procedure: extract info from textmetric} win { font metric systemfixed -fixed } {1} # cleanup destroy .b -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/winMenu.test b/tests/winMenu.test index f29face..7240bf5 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -8,29 +8,26 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -test winMenu-1.1 {GetNewID} {pcOnly} { +test winMenu-1.1 {GetNewID} win { catch {destroy .m1} list [catch {menu .m1} msg] $msg [destroy .m1] } {0 .m1 {}} # Basically impossible to test menu IDs wrapping. -test winMenu-2.1 {FreeID} {pcOnly} { +test winMenu-2.1 {FreeID} win { catch {destroy .m1} menu .m1 list [catch {destroy .m1} msg] $msg } {0 {}} -test winMenu-3.1 {TkpNewMenu} {pcOnly} { +test winMenu-3.1 {TkpNewMenu} win { catch {destroy .m1} list [catch {menu .m1} msg] $msg [catch {destroy .m1} msg2] $msg2 } {0 .m1 0 {}} -test winMenu-3.2 {TkpNewMenu} {pcOnly} { +test winMenu-3.2 {TkpNewMenu} win { catch {destroy .m1} . configure -menu "" menu .m1 @@ -38,12 +35,12 @@ test winMenu-3.2 {TkpNewMenu} {pcOnly} { list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2 } {0 {} {} 0 {}} -test winMenu-4.1 {TkpDestroyMenu} {pcOnly} { +test winMenu-4.1 {TkpDestroyMenu} win { catch {destroy .m1} menu .m1 list [catch {destroy .m1} msg] $msg } {0 {}} -test winMenu-4.2 {TkpDestroyMenu - help menu} {pcOnly} { +test winMenu-4.2 {TkpDestroyMenu - help menu} win { catch {destroy .m1} menu .m1 .m1 add cascade -menu .m1.system @@ -51,7 +48,7 @@ test winMenu-4.2 {TkpDestroyMenu - help menu} {pcOnly} { list [catch {destroy .m1.system} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-5.1 {TkpDestroyMenuEntry} {pcOnly} { +test winMenu-5.1 {TkpDestroyMenuEntry} win { catch {destroy .m1} . configure -menu "" menu .m1 @@ -60,89 +57,89 @@ test winMenu-5.1 {TkpDestroyMenuEntry} {pcOnly} { list [catch {.m1 delete 1} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.1 {GetEntryText} {pcOnly} { +test winMenu-6.1 {GetEntryText} win { catch {destroy .m1} list [catch {menu .m1} msg] $msg [destroy .m1] } {0 .m1 {}} -test winMenu-6.2 {GetEntryText} {testImageType pcOnly} { +test winMenu-6.2 {GetEntryText} {testImageType win} { catch {destroy .m1} catch {image delete image1} menu .m1 image create test image1 list [catch {.m1 add command -image image1} msg] $msg [destroy .m1] [image delete image1] } {0 {} {} {}} -test winMenu-6.3 {GetEntryText} {pcOnly} { +test winMenu-6.3 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -bitmap questhead} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.4 {GetEntryText} {pcOnly} { +test winMenu-6.4 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.5 {GetEntryText} {pcOnly} { +test winMenu-6.5 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "foo"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.6 {GetEntryText} {pcOnly} { +test winMenu-6.6 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "This string has one & in it"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.7 {GetEntryText} {pcOnly} { +test winMenu-6.7 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.8 {GetEntryText} {pcOnly} { +test winMenu-6.8 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.9 {GetEntryText} {pcOnly} { +test winMenu-6.9 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "foo" -accel "bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.10 {GetEntryText} {pcOnly} { +test winMenu-6.10 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "This string has one & in it" -accel "bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.11 {GetEntryText} {pcOnly} { +test winMenu-6.11 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.12 {GetEntryText} {pcOnly} { +test winMenu-6.12 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.13 {GetEntryText} {pcOnly} { +test winMenu-6.13 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "foo" -accel "&bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.14 {GetEntryText} {pcOnly} { +test winMenu-6.14 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "This string has one & in it" -accel "&bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.15 {GetEntryText} {pcOnly} { +test winMenu-6.15 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.16 {GetEntryText} {pcOnly} { +test winMenu-6.16 {GetEntryText} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} {pcOnly} { +test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} win { catch {destroy .m1} menu .m1 .m1 add cascade -menu .m1.system @@ -152,7 +149,7 @@ test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} {pcOnly} { .m1.system add command -label bar list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} {pcOnly} { +test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} win { catch {destroy .m1} menu .m1 .m1 add command -label Hello @@ -160,77 +157,77 @@ test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} {pcOnly} { .m1 add command -label foo list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.3 {ReconfigureWindowsMenu - zero items} {pcOnly} { +test winMenu-7.3 {ReconfigureWindowsMenu - zero items} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello .m1 delete Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.4 {ReconfigureWindowsMenu - one item} {pcOnly} { +test winMenu-7.4 {ReconfigureWindowsMenu - one item} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.5 {ReconfigureWindowsMenu - two items} {pcOnly} { +test winMenu-7.5 {ReconfigureWindowsMenu - two items} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label One .m1 add command -label Two list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.6 {ReconfigureWindowsMenu - separator item} {pcOnly} { +test winMenu-7.6 {ReconfigureWindowsMenu - separator item} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add separator list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.7 {ReconfigureWindowsMenu - non-text item} {pcOnly} { +test winMenu-7.7 {ReconfigureWindowsMenu - non-text item} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.8 {ReconfigureWindowsMenu - disabled item} {pcOnly} { +test winMenu-7.8 {ReconfigureWindowsMenu - disabled item} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello -state disabled list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.9 {ReconfigureWindowsMenu - non-selected checkbutton} {pcOnly} { +test winMenu-7.9 {ReconfigureWindowsMenu - non-selected checkbutton} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add checkbutton -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.10 {ReconfigureWindowsMenu - non-selected radiobutton} {pcOnly} { +test winMenu-7.10 {ReconfigureWindowsMenu - non-selected radiobutton} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add radiobutton -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.11 {ReconfigureWindowsMenu - selected checkbutton} {pcOnly} { +test winMenu-7.11 {ReconfigureWindowsMenu - selected checkbutton} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add checkbutton -label Hello .m1 invoke Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.12 {ReconfigureWindowsMenu - selected radiobutton} {pcOnly} { +test winMenu-7.12 {ReconfigureWindowsMenu - selected radiobutton} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add radiobutton -label Hello .m1 invoke Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.13 {ReconfigureWindowsMenu - cascade missing} {pcOnly} { +test winMenu-7.13 {ReconfigureWindowsMenu - cascade missing} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.14 {ReconfigureWindowsMenu - cascade} {pcOnly} { +test winMenu-7.14 {ReconfigureWindowsMenu - cascade} win { catch {destroy .m1} catch {destroy .m2} menu .m1 -tearoff 0 @@ -238,7 +235,7 @@ test winMenu-7.14 {ReconfigureWindowsMenu - cascade} {pcOnly} { .m1 add cascade -menu .m2 -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] [destroy .m2] } {0 {} {} {}} -test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} {pcOnly} { +test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -menu .m1.file @@ -246,7 +243,7 @@ test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} {pcOnly . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} {pcOnly} { +test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system @@ -256,7 +253,7 @@ test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} {pcOnly .m1.system add command -label Hello list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} {pcOnly} { +test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system @@ -264,7 +261,7 @@ test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} {pcOnly} . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} {pcOnly} { +test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system @@ -274,7 +271,7 @@ test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} {pcO . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.19 {ReconfigureWindowsMenu - column break} {pcOnly} { +test winMenu-7.19 {ReconfigureWindowsMenu - column break} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label one @@ -283,23 +280,23 @@ test winMenu-7.19 {ReconfigureWindowsMenu - column break} {pcOnly} { } {0 {} {}} #Don't know how to generate nested post menus -test winMenu-8.1 {TkpPostMenu} {pcOnly} { +test winMenu-8.1 {TkpPostMenu} win { catch {destroy .m1} menu .m1 -postcommand "blork" list [catch {.m1 post 40 40} msg] $msg [destroy .m1] } {1 {invalid command name "blork"} {}} -test winMenu-8.2 {TkpPostMenu} {pcOnly} { +test winMenu-8.2 {TkpPostMenu} win { catch {destroy .m1} menu .m1 -postcommand "destroy .m1" list [.m1 post 40 40] [winfo exists .m1] } {{} 0} -test winMenu-8.3 {TkpPostMenu - popup menu} {pcOnly userInteraction} { +test winMenu-8.3 {TkpPostMenu - popup menu} {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-8.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-8.4 {TkpPostMenu - menu button} {pcOnly userInteraction} { +test winMenu-8.4 {TkpPostMenu - menu button} {win userInteraction} { catch {destroy .mb} menubutton .mb -text test -menu .mb.menu menu .mb.menu @@ -307,7 +304,7 @@ test winMenu-8.4 {TkpPostMenu - menu button} {pcOnly userInteraction} { pack .mb list [tk::MbPost .mb] [destroy .m1] } {{} {}} -test winMenu-8.5 {TkpPostMenu - update not pending} {pcOnly userInteraction} { +test winMenu-8.5 {TkpPostMenu - update not pending} {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-8.5 - Hit ESCAPE." @@ -315,13 +312,13 @@ test winMenu-8.5 {TkpPostMenu - update not pending} {pcOnly userInteraction} { list [catch {.m1 post 40 40} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-9.1 {TkpMenuNewEntry} {pcOnly} { +test winMenu-9.1 {TkpMenuNewEntry} win { catch {destroy .m1} menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-10.1 {TkwinMenuProc} {pcOnly userInteraction} { +test winMenu-10.1 {TkwinMenuProc} {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-10.1: Hit ESCAPE." @@ -329,21 +326,21 @@ test winMenu-10.1 {TkwinMenuProc} {pcOnly userInteraction} { } {{} {}} # Can't generate a WM_INITMENU without a Tk menu yet. -test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} {pcOnly userInteraction} { +test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} {win userInteraction} { catch {destroy .m1} catch {unset foo} menu .m1 -postcommand "set foo test" .m1 add command -label "winMenu-11.1: Hit ESCAPE." list [.m1 post 40 40] [set foo] [unset foo] [destroy .m1] } {test test {} {}} -test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly userInteraction} { +test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} {win userInteraction} { catch {destroy .m1} catch {unset foo} menu .m1 .m1 add checkbutton -variable foo -label "winMenu-11.2: Please select this menu item." list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] } {{} {} 1 {} {}} -test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly userInteraction} { +test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {win userInteraction} { catch {destroy .m1} catch {unset foo} proc bgerror {args} { @@ -359,33 +356,33 @@ test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly userInteraction} { (menu invoke)}} {} {}} # Can't test WM_MENUCHAR -test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {pcOnly userInteraction} { +test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} {pcOnly userInteraction} { +test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label "winMenu-11.4: Hit ESCAPE" -hidemargin 1 list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} {pcOnly userInteraction} { +test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} test winMenu-11.7 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} \ - {pcOnly userInteraction} { + {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.6: Hit ESCAPE." -state disabled list [.m1 post 40 40] [destroy .m1] } {{} {}} test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} \ - {pcOnly userInteraction} { + {win userInteraction} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label "winMenu-11.7: Hit ESCAPE" @@ -393,14 +390,14 @@ test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} \ list [catch {.m1 post 40 40} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-12.1 {TkpSetWindowMenuBar} {pcOnly} { +test winMenu-12.1 {TkpSetWindowMenuBar} win { catch {destroy .m1} . configure -menu "" menu .m1 .m1 add command -label foo list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2 } {0 {} {} 0 {}} -test winMenu-12.2 {TkpSetWindowMenuBar} {pcOnly} { +test winMenu-12.2 {TkpSetWindowMenuBar} win { catch {destroy .m1} . configure -menu "" menu .m1 @@ -408,7 +405,7 @@ test winMenu-12.2 {TkpSetWindowMenuBar} {pcOnly} { . configure -menu .m1 list [catch {. configure -menu ""} msg] $msg [catch {destroy .m1} msg2] $msg2 } {0 {} 0 {}} -test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} {pcOnly} { +test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} win { catch {destroy .m1} . configure -menu "" menu .m1 -tearoff 0 @@ -417,48 +414,48 @@ test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} {pcOnly} { list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-13.1 {TkpSetMainMenubar - nothing to do} {emptyTest pcOnly} {} {} +test winMenu-13.1 {TkpSetMainMenubar - nothing to do} {emptyTest win} {} {} -test winMenu-14.1 {GetMenuIndicatorGeometry} {pcOnly} { +test winMenu-14.1 {GetMenuIndicatorGeometry} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-14.2 {GetMenuIndicatorGeometry} {pcOnly} { +test winMenu-14.2 {GetMenuIndicatorGeometry} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo -hidemargin 1 list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-15.1 {GetMenuAccelGeometry} {pcOnly} { +test winMenu-15.1 {GetMenuAccelGeometry} win { catch {destroy .m1} menu .m1 .m1 add cascade -label foo -accel Ctrl+U list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-15.2 {GetMenuAccelGeometry} {pcOnly} { +test winMenu-15.2 {GetMenuAccelGeometry} win { catch {destroy .m1} menu .m1 .m1 add command -label foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-15.3 {GetMenuAccelGeometry} {pcOnly} { +test winMenu-15.3 {GetMenuAccelGeometry} win { catch {destroy .m1} menu .m1 .m1 add command -label foo -accel "Ctrl+U" list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-16.1 {GetTearoffEntryGeometry} {pcOnly userInteraction} { +test winMenu-16.1 {GetTearoffEntryGeometry} {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-19.1: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-17.1 {GetMenuSeparatorGeometry} {pcOnly} { +test winMenu-17.1 {GetMenuSeparatorGeometry} win { catch {destroy .m1} menu .m1 .m1 add separator @@ -467,7 +464,7 @@ test winMenu-17.1 {GetMenuSeparatorGeometry} {pcOnly} { # Currently, the only callers to DrawWindowsSystemBitmap want things # centered vertically, and either centered or right aligned horizontally. -test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} {pcOnly} { +test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -475,7 +472,7 @@ test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} {pcOnly} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} {pcOnly} { +test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} win { catch {destroy .m1} menu .m1 .m1 add cascade -label foo @@ -484,21 +481,21 @@ test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} {pcOnly} { } {{} {}} test winMenu-19.1 {DrawMenuEntryIndicator - not checkbutton or radiobutton} \ - {pcOnly} { + win { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.2 {DrawMenuEntryIndicator - not selected} {pcOnly} { +test winMenu-19.2 {DrawMenuEntryIndicator - not selected} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} {pcOnly} { +test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -506,7 +503,7 @@ test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} {pcOnly} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} {pcOnly} { +test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} win { catch {destroy .m1} menu .m1 .m1 add radiobutton -label foo @@ -514,7 +511,7 @@ test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} {pcOnly} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.5 {DrawMenuEntryIndicator - disabled} {pcOnly} { +test winMenu-19.5 {DrawMenuEntryIndicator - disabled} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -523,7 +520,7 @@ test winMenu-19.5 {DrawMenuEntryIndicator - disabled} {pcOnly} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} {pcOnly} { +test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo -indicatoron 0 @@ -532,29 +529,28 @@ test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} {pcOnly} { list [update] [destroy .m1] } {{} {}} -test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} {pcOnly} { +test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} win { catch {destroy .m1} menu .m1 -disabledforeground red .m1 add command -label foo -accel "Ctrl+U" -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} {pcOnly} { +test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} win { catch {destroy .m1} menu .m1 .m1 add command -label foo -accel "Ctrl+U" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} \ - {pcOnly} { +test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} win { catch {destroy .m1} menu .m1 -disabledforeground "" .m1 add command -label foo -accel "Ctrl+U" -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} {pcOnly} { +test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} win { catch {destroy .m1} menu .m1 .m1 add cascade -label foo @@ -562,14 +558,14 @@ test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} {pcOnly} list [update] [destroy .m1] } {{} {}} test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} \ - {pcOnly userInteraction} { + {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add cascade -label "winMenu-23.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-21.1 {DrawMenuSeparator} {pcOnly} { +test winMenu-21.1 {DrawMenuSeparator} win { catch {destroy .m1} menu .m1 .m1 add separator @@ -577,7 +573,7 @@ test winMenu-21.1 {DrawMenuSeparator} {pcOnly} { list [update] [destroy .m1] } {{} {}} -test winMenu-22.1 {DrawMenuUnderline} {pcOnly} { +test winMenu-22.1 {DrawMenuUnderline} win { catch {destroy .m1} menu .m1 .m1 add command -label foo -underline 0 @@ -586,25 +582,25 @@ test winMenu-22.1 {DrawMenuUnderline} {pcOnly} { } {{} {}} test winMenu-23.1 {Don't know how to test MenuKeyBindProc} \ - {pcOnly emptyTest} {} {} + {win emptyTest} {} {} test winMenu-24.1 {TkpInitializeMenuBindings called at boot time} \ - {pcOnly emptyTest} {} {} + {win emptyTest} {} {} -test winMenu-25.1 {DrawMenuEntryLabel - normal} {pcOnly} { +test winMenu-25.1 {DrawMenuEntryLabel - normal} win { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} {pcOnly} { +test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} win { catch {destroy .m1} menu .m1 -disabledforeground red .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} {pcOnly} { +test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} win { catch {destroy .m1} menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled @@ -612,27 +608,27 @@ test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} {pcOnly} { list [update] [destroy .m1] } {{} {}} -test winMenu-26.1 {TkpComputeMenubarGeometry} {pcOnly} { +test winMenu-26.1 {TkpComputeMenubarGeometry} win { catch {destroy .m1} menu .m1 .m1 add cascade -label File list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] } {{} {} {}} -test winMenu-27.1 {DrawTearoffEntry} {pcOnly userInteraction} { +test winMenu-27.1 {DrawTearoffEntry} {win userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-24.4: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-28.1 {TkpConfigureMenuEntry - update pending} {pcOnly} { +test winMenu-28.1 {TkpConfigureMenuEntry - update pending} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {.m1 add command -label Two} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} {pcOnly} { +test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label One @@ -640,8 +636,7 @@ test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} {pcOnly} { list [catch {.m1 add command -label Two} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} \ - {pcOnly} { +test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} win { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -649,8 +644,7 @@ test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} \ .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} \ - {pcOnly} { +test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} win { catch {destroy .m1} menu .m1 .m1 add command -label foo -activeforeground red @@ -658,7 +652,7 @@ test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} \ .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} {pcOnly} { +test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} win { catch {destroy .m1} menu .m1 set tk_strictMotif 1 @@ -669,42 +663,42 @@ test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} {pcOnly} { } {{} {} 0} test winMenu-29.4 \ {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} \ - {pcOnly} { + win { catch {destroy .m1} menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled -background red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} {pcOnly} { +test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} win { catch {destroy .m1} menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} {pcOnly} { +test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} win { catch {destroy .m1} menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} {pcOnly} { +test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} win { catch {destroy .m1} menu .m1 .m1 add command -label foo -foreground red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} {pcOnly} { +test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} win { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} {pcOnly} { +test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo -selectcolor orange @@ -712,7 +706,7 @@ test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} {pcOnly} set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} {pcOnly} { +test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -720,7 +714,7 @@ test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} {pcOnly} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} {pcOnly} { +test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} win { catch {destroy .m1} menu .m1 .m1 add command -label foo -activebackground green @@ -728,7 +722,7 @@ test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} {pcOnly} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.12 {TkpDrawMenuEntry - border} {pcOnly} { +test winMenu-29.12 {TkpDrawMenuEntry - border} win { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -736,7 +730,7 @@ test winMenu-29.12 {TkpDrawMenuEntry - border} {pcOnly} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} {pcOnly} { +test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} win { catch {destroy .m1} set tk_strictMotif 1 menu .m1 @@ -745,7 +739,7 @@ test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} {pcOnly} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] } {{} {} 0} -test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} {pcOnly} { +test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} win { catch {destroy .m1} menu .m1 .m1 add command -label foo -activeforeground yellow @@ -753,7 +747,7 @@ test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} {pcOnly} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.15 {TkpDrawMenuEntry - active border} {pcOnly} { +test winMenu-29.15 {TkpDrawMenuEntry - active border} win { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -761,35 +755,35 @@ test winMenu-29.15 {TkpDrawMenuEntry - active border} {pcOnly} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} {pcOnly} { +test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} win { catch {destroy .m1} menu .m1 .m1 add command -label foo -font "Helvectica 72" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.17 {TkpDrawMenuEntry - font} {pcOnly} { +test winMenu-29.17 {TkpDrawMenuEntry - font} win { catch {destroy .m1} menu .m1 -font "Courier 72" .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.18 {TkpDrawMenuEntry - separator} {pcOnly} { +test winMenu-29.18 {TkpDrawMenuEntry - separator} win { catch {destroy .m1} menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.19 {TkpDrawMenuEntry - standard} {pcOnly} { +test winMenu-29.19 {TkpDrawMenuEntry - standard} win { catch {destroy .mb} menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} {pcOnly} { +test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} win { catch {destroy .m1} menu .m1 .m1 add cascade -label File -menu .m1.file @@ -799,7 +793,7 @@ test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} {pcOnly} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.21 {TkpDrawMenuEntry - indicator} {pcOnly} { +test winMenu-29.21 {TkpDrawMenuEntry - indicator} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label winMenu-31.20 @@ -807,7 +801,7 @@ test winMenu-29.21 {TkpDrawMenuEntry - indicator} {pcOnly} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.22 {TkpDrawMenuEntry - indicator} {pcOnly} { +test winMenu-29.22 {TkpDrawMenuEntry - indicator} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label winMenu-31.21 -hidemargin 1 @@ -816,7 +810,7 @@ test winMenu-29.22 {TkpDrawMenuEntry - indicator} {pcOnly} { list [update] [destroy .m1] } {{} {}} -test winMenu-30.1 {GetMenuLabelGeometry - image} {testImageType pcOnly} { +test winMenu-30.1 {GetMenuLabelGeometry - image} {testImageType win} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -824,33 +818,33 @@ test winMenu-30.1 {GetMenuLabelGeometry - image} {testImageType pcOnly} { .m1 add command -image image1 list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test winMenu-30.2 {GetMenuLabelGeometry - bitmap} {pcOnly} { +test winMenu-30.2 {GetMenuLabelGeometry - bitmap} win { catch {destroy .m1} menu .m1 .m1 add command -bitmap questhead list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-30.3 {GetMenuLabelGeometry - no text} {pcOnly} { +test winMenu-30.3 {GetMenuLabelGeometry - no text} win { catch {destroy .m1} menu .m1 .m1 add command list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-30.4 {GetMenuLabelGeometry - text} {pcOnly} { +test winMenu-30.4 {GetMenuLabelGeometry - text} win { catch {destroy .m1} menu .m1 .m1 add command -label "This is a test." list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-31.1 {DrawMenuEntryBackground} {pcOnly} { +test winMenu-31.1 {DrawMenuEntryBackground} win { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-31.2 {DrawMenuEntryBackground} {pcOnly} { +test winMenu-31.2 {DrawMenuEntryBackground} win { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -859,31 +853,31 @@ test winMenu-31.2 {DrawMenuEntryBackground} {pcOnly} { list [update] [destroy .m1] } {{} {}} -test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} {pcOnly} { +test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} win { catch {destroy .m1} menu .m1 list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} {pcOnly} { +test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} win { catch {destroy .m1} menu .m1 .m1 add command -label "one" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} {pcOnly} { +test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} win { catch {destroy .m1} menu .m1 .m1 add command -label "one" .m1 add command -label "two" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.4 {TkpComputeStandardMenuGeometry - separator} {pcOnly} { +test winMenu-32.4 {TkpComputeStandardMenuGeometry - separator} win { catch {destroy .m1} menu .m1 .m1 add separator list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} { +test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unix nonUnixUserInteraction} { catch {destroy .m1} menubutton .mb -text "test" -menu .mb.m menu .mb.m @@ -893,55 +887,54 @@ test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} { list [update] [destroy .mb] } {{} {}} test winMenu-32.6 {TkpComputeStandardMenuGeometry - standard label geometry} \ - {pcOnly} { + win { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [update idletasks] [destroy .m1] } {{} {}} test winMenu-32.7 {TkpComputeStandardMenuGeometry - different font for entry} \ - {pcOnly} { + win { catch {destroy .m1} menu .m1 -font "Helvetica 12" .m1 add command -label "test" -font "Courier 12" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.8 {TkpComputeStandardMenuGeometry - second entry larger} \ - {pcOnly} { +test winMenu-32.8 {TkpComputeStandardMenuGeometry - second entry larger} win { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 add command -label "test test" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.9 {TkpComputeStandardMenuGeometry - first entry larger} {pcOnly} { +test winMenu-32.9 {TkpComputeStandardMenuGeometry - first entry larger} win { catch {destroy .m1} menu .m1 .m1 add command -label "test test" .m1 add command -label "test" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.10 {TkpComputeStandardMenuGeometry - accelerator} {pcOnly} { +test winMenu-32.10 {TkpComputeStandardMenuGeometry - accelerator} win { catch {destroy .m1} menu .m1 .m1 add command -label "test" -accel "Ctrl+S" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.11 {TkpComputeStandardMenuGeometry - second accel larger} {pcOnly} { +test winMenu-32.11 {TkpComputeStandardMenuGeometry - second accel larger} win { catch {destroy .m1} menu .m1 .m1 add command -label "test" -accel "1" .m1 add command -label "test" -accel "1 1" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.12 {TkpComputeStandardMenuGeometry - second accel smaller} {pcOnly} { +test winMenu-32.12 {TkpComputeStandardMenuGeometry - second accel smaller} win { catch {destroy .m1} menu .m1 .m1 add command -label "test" -accel "1 1" .m1 add command -label "test" -accel "1" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} {pcOnly} { +test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} win { catch {destroy .m1} menu .m1 .m1 add checkbutton -label test @@ -950,7 +943,7 @@ test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} {pcOnly} { } {{} {}} test winMenu-32.14 \ {TkpComputeStandardMenuGeometry - second indicator less or equal} \ - {testImageType pcOnly} { + {testImageType win} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -962,7 +955,7 @@ test winMenu-32.14 \ list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} \ - {testImageType unixOnly} { + {testImageType unix} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -973,14 +966,12 @@ test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} \ .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} \ - {pcOnly} { +test winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} win { catch {destroy .m1} menu .m1 -tearoff 0 list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} \ - {pcOnly} { +test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} win { catch {destroy .m1} menu .m1 .m1 add command -label one @@ -989,7 +980,7 @@ test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} \ list [update idletasks] [destroy .m1] } {{} {}} test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} \ - {pcOnly} { + win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label one @@ -997,7 +988,7 @@ test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} \ .m1 add command -label three list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} {pcOnly} { +test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} win { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label one @@ -1009,14 +1000,14 @@ test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} {pcOnly} { list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} {pcOnly} { +test winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} win { catch {destroy .t2} catch {destroy .m1} toplevel .t2 -menu .m1 wm geometry .t2 +0+0 list [update idletasks] [destroy .t2] } {{} {}} -test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} {pcOnly} { +test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} win { catch {destroy .t2} catch {destroy .m1} menu .m1 @@ -1029,9 +1020,9 @@ test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} {pcOnly} { list [update idletasks] [destroy .m1] [destroy .t2] } {{} {} {}} -test winMenu-34.1 {TkpMenuInit called at boot time} {emptyTest pcOnly} {} {} +test winMenu-34.1 {TkpMenuInit called at boot time} {emptyTest win} {} {} # cleanup deleteWindows -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/winMsgbox.test b/tests/winMsgbox.test new file mode 100644 index 0000000..f467896 --- /dev/null +++ b/tests/winMsgbox.test @@ -0,0 +1,297 @@ +# This file is a Tcl script to test the Windows specific message box +# +# Copyright (c) 2007 Pat Thoyts <patthoyts@users.sourceforge.net> + +package require tcltest 2.1 +eval tcltest::configure $argv +tcltest::loadTestedCommands + +testConstraint getwindowinfo [expr {[llength [info command ::testgetwindowinfo]] > 0}] + +if {[testConstraint testwinevent]} { + catch {testwinevent debug 1} +} + +proc Click {hwnd button} { + testwinevent $hwnd $button WM_COMMAND +} + +proc GetWindowInfo {title button} { + global windowInfo + set windowInfo {} + set hwnd [testfindwindow $title "#32770"] + set windowInfo [testgetwindowinfo $hwnd] + array set a $windowInfo + set childinfo {} ; set childtext "" + foreach child $a(children) { + lappend childinfo $child [set info [testgetwindowinfo $child]] + array set ca $info + if {$ca(class) eq "Static"} { + append childtext $ca(text) + } + } + set a(children) $childinfo + set a(childtext) $childtext + set windowInfo [array get a] + testwinevent $hwnd $button WM_COMMAND +} + +# ------------------------------------------------------------------------- + +test winMsgbox-1.0 {tk_messageBox ok} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.0 [pid]" + after 100 [list GetWindowInfo $title 2] + tk_messageBox -icon info -type ok -title $title -message Message +} -cleanup { + wm deiconify . +} -result {ok} + +test winMsgbox-1.1 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.1 [pid]" + after 100 [list GetWindowInfo $title 1] + tk_messageBox -icon info -type okcancel -title $title -message Message +} -cleanup { + wm deiconify . +} -result {ok} + +test winMsgbox-1.2 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.2 [pid]" + after 100 [list GetWindowInfo $title 2] + tk_messageBox -icon info -type okcancel -title $title -message Message +} -cleanup { + wm deiconify . +} -result {cancel} + +test winMsgbox-1.3 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.3 [pid]" + after 100 [list GetWindowInfo $title 6] + tk_messageBox -icon info -type yesno -title $title -message Message +} -cleanup { + wm deiconify . +} -result {yes} + +test winMsgbox-1.4 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.4 [pid]" + after 100 [list GetWindowInfo $title 7] + tk_messageBox -icon info -type yesno -title $title -message Message +} -cleanup { + wm deiconify . +} -result {no} + +test winMsgbox-1.5 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.5 [pid]" + after 100 [list GetWindowInfo $title 3] + tk_messageBox -icon info -type abortretryignore -title $title -message Message +} -cleanup { + wm deiconify . +} -result {abort} + +test winMsgbox-1.6 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.6 [pid]" + after 100 [list GetWindowInfo $title 4] + tk_messageBox -icon info -type abortretryignore -title $title -message Message +} -cleanup { + wm deiconify . +} -result {retry} + +test winMsgbox-1.7 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.7 [pid]" + after 100 [list GetWindowInfo $title 5] + tk_messageBox -icon info -type abortretryignore -title $title -message Message +} -cleanup { + wm deiconify . +} -result {ignore} + +test winMsgbox-1.8 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.8 [pid]" + after 100 [list GetWindowInfo $title 4] + tk_messageBox -icon info -type retrycancel -title $title -message Message +} -cleanup { + wm deiconify . +} -result {retry} + +test winMsgbox-1.9 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.9 [pid]" + after 100 [list GetWindowInfo $title 2] + tk_messageBox -icon info -type retrycancel -title $title -message Message +} -cleanup { + wm deiconify . +} -result {cancel} + +test winMsgbox-1.10 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.10 [pid]" + after 100 [list GetWindowInfo $title 6] + tk_messageBox -icon info -type yesnocancel -title $title -message Message +} -cleanup { + wm deiconify . +} -result {yes} + +test winMsgbox-1.11 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.11 [pid]" + after 100 [list GetWindowInfo $title 7] + tk_messageBox -icon info -type yesnocancel -title $title -message Message +} -cleanup { + wm deiconify . +} -result {no} + +test winMsgbox-1.12 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { + wm iconify . +} -body { + global windowInfo + set title "winMsgbox-1.12 [pid]" + after 100 [list GetWindowInfo $title 2] + tk_messageBox -icon info -type yesnocancel -title $title -message Message +} -cleanup { + wm deiconify . +} -result {cancel} + +# ------------------------------------------------------------------------- + +test winMsgbox-2.0 {tk_messageBox message} -constraints {win getwindowinfo} -setup { + wm iconify . + unset -nocomplain info +} -body { + global windowInfo + set title "winMsgbox-2.0 [pid]" + set message "message" + after 100 [list GetWindowInfo $title 2] + set r [tk_messageBox -type ok -title $title -message $message] + array set info $windowInfo + lappend r $info(childtext) +} -cleanup { + wm deiconify . +} -result [list ok "message"] + +test winMsgbox-2.1 {tk_messageBox message (long)} -constraints { + win getwindowinfo +} -setup { + wm iconify . + unset -nocomplain info +} -body { + global windowInfo + set title "winMsgbox-2.1 [pid]" + set message [string repeat Ab 80] + after 100 [list GetWindowInfo $title 2] + set r [tk_messageBox -type ok -title $title -message $message] + array set info $windowInfo + lappend r $info(childtext) +} -cleanup { + wm deiconify . +} -result [list ok [string repeat Ab 80]] + +test winMsgbox-2.2 {tk_messageBox message (unicode)} -constraints { + win getwindowinfo +} -setup { + wm iconify . + unset -nocomplain info +} -body { + global windowInfo + set title "winMsgbox-2.2 [pid]" + set message "\u041f\u043e\u0438\u0441\u043a\u0020\u0441\u0442\u0440\u0430\u043d\u0438\u0446" + after 100 [list GetWindowInfo $title 2] + set r [tk_messageBox -type ok -title $title -message $message] + array set info $windowInfo + lappend r $info(childtext) +} -cleanup { + wm deiconify . +} -result [list ok "\u041f\u043e\u0438\u0441\u043a\u0020\u0441\u0442\u0440\u0430\u043d\u0438\u0446"] + +test winMsgbox-2.3 {tk_messageBox message (empty)} -constraints { + win getwindowinfo +} -setup { + wm iconify . + unset -nocomplain info +} -body { + global windowInfo + set title "winMsgbox-2.3 [pid]" + after 100 [list GetWindowInfo $title 2] + set r [tk_messageBox -type ok -title $title] + array set info $windowInfo + lappend r $info(childtext) +} -cleanup { + wm deiconify . +} -result [list ok ""] + +test winMsgbox-3.0 {tk_messageBox detail (sourceforge bug #1692927)} -constraints { + win getwindowinfo +} -setup { + wm iconify . + unset -nocomplain info +} -body { + global windowInfo + set title "winMsgbox-3.0 [pid]" + after 100 [list GetWindowInfo $title 2] + set r [tk_messageBox -type ok -title $title \ + -message Hello -detail "Pleased to meet you"] + array set info $windowInfo + lappend r $info(childtext) +} -cleanup { + wm deiconify . +} -result [list ok "Hello\n\nPleased to meet you"] + +test winMsgbox-3.1 {tk_messageBox detail (unicode)} -constraints { + win getwindowinfo +} -setup { + wm iconify . + unset -nocomplain info +} -body { + global windowInfo + set title "winMsgbox-3.1 [pid]" + set message "\u041f\u043e\u0438\u0441\u043a" + set detail "\u0441\u0442\u0440\u0430\u043d\u0438\u0446" + after 100 [list GetWindowInfo $title 2] + set r [tk_messageBox -type ok -title $title -message $message -detail $detail] + array set info $windowInfo + lappend r $info(childtext) +} -cleanup { + wm deiconify . +} -result [list ok "\u041f\u043e\u0438\u0441\u043a\n\n\u0441\u0442\u0440\u0430\u043d\u0438\u0446"] + +# ------------------------------------------------------------------------- + +if {[testConstraint testwinevent]} { + catch {testwinevent debug 0} +} +cleanupTests +return + +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tests/winSend.test b/tests/winSend.test index 03f7172..cd130fb 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -8,14 +8,9 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::interpreter - # Compute a script that will load Tk into a child interpreter. foreach pkg [info loaded] { @@ -39,27 +34,32 @@ proc newApp {name {safe {}}} { } set currentInterps [winfo interps] -if {[testConstraint win] && [llength [info commands send]]} { - - if {[catch {exec [interpreter] &}] == 0} { - - # Wait until the child application has launched. - while {[llength [winfo interps]] == [llength $currentInterps]} {} +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]} {} - # 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 @@ -68,9 +68,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] @@ -99,16 +97,16 @@ test winSend-1.6 {Tk_SetAppName - safe interps} winSend { test winSend-2.1 {Tk_SendObjCmd - # of args} winSend { list [catch {send tktest} msg] $msg } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} -test winSend-2.1 {Tk_SendObjCmd: arguments} winSend { +test winSend-2.1a {Tk_SendObjCmd: arguments} winSend { list [catch {send -bogus tktest} msg] $msg } {1 {bad option "-bogus": must be -async, -displayof, or --}} -test winSend-2.1 {Tk_SendObjCmd: arguments} winSend { +test winSend-2.1b {Tk_SendObjCmd: arguments} winSend { list [catch {send -async bogus foo} msg] $msg } {1 {no registered server named "bogus"}} -test winSend-2.1 {Tk_SendObjCmd: arguments} winSend { +test winSend-2.1c {Tk_SendObjCmd: arguments} winSend { list [catch {send -displayof . bogus foo} msg] $msg } {1 {no registered server named "bogus"}} -test winSend-2.1 {Tk_SendObjCmd: arguments} winSend { +test winSend-2.1d {Tk_SendObjCmd: arguments} winSend { list [catch {send -- -bogus foo} msg] $msg } {1 {no registered server named "-bogus"}} test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} winSend { @@ -405,6 +403,5 @@ while {[llength $newInterps] != [llength $currentInterps]} { } # cleanup -::tcltest::cleanupTests +cleanupTests return - diff --git a/tests/winWm.test b/tests/winWm.test index ff537a4..2864418 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -10,10 +10,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # Measure the height of a single menu line @@ -23,17 +20,17 @@ frame .t.f -width 100 -height 50 pack .t.f menu .t.m .t.m add command -label "thisisreallylong" -.t conf -menu .t.m -wm geom .t -0-0 +.t configure -menu .t.m +wm geometry .t -0-0 update set menuheight [winfo y .t] .t.m add command -label "thisisreallylong" -wm geom .t -0-0 +wm geometry .t -0-0 update -set menuheight [expr $menuheight - [winfo y .t]] +set menuheight [expr {$menuheight - [winfo y .t]}] destroy .t -test winWm-1.1 {TkWmMapWindow} {pcOnly} { +test winWm-1.1 {TkWmMapWindow} win { toplevel .t wm override .t 1 wm geometry .t +0+0 @@ -42,7 +39,7 @@ test winWm-1.1 {TkWmMapWindow} {pcOnly} { destroy .t set result } {0 0} -test winWm-1.2 {TkWmMapWindow} {pcOnly} { +test winWm-1.2 {TkWmMapWindow} win { toplevel .t wm transient .t . update @@ -54,16 +51,16 @@ test winWm-1.2 {TkWmMapWindow} {pcOnly} { destroy .t set msg } {can't iconify ".t": it is a transient} -test winWm-1.3 {TkWmMapWindow} {pcOnly} { +test winWm-1.3 {TkWmMapWindow} win { toplevel .t update toplevel .t2 update - set result [expr [winfo x .t] != [winfo x .t2]] + set result [expr {[winfo x .t] != [winfo x .t2]}] destroy .t .t2 set result } 1 -test winWm-1.4 {TkWmMapWindow} {pcOnly} { +test winWm-1.4 {TkWmMapWindow} win { toplevel .t wm geometry .t +10+10 update @@ -74,7 +71,7 @@ test winWm-1.4 {TkWmMapWindow} {pcOnly} { destroy .t .t2 set result } {10 40} -test winWm-1.5 {TkWmMapWindow} {pcOnly} { +test winWm-1.5 {TkWmMapWindow} win { toplevel .t wm iconify .t update @@ -83,7 +80,7 @@ test winWm-1.5 {TkWmMapWindow} {pcOnly} { set result } iconic -test winWm-2.1 {TkpWmSetState} {pcOnly} { +test winWm-2.1 {TkpWmSetState} win { toplevel .t wm geometry .t 150x50+10+10 update @@ -97,7 +94,7 @@ test winWm-2.1 {TkpWmSetState} {pcOnly} { destroy .t set result } {normal iconic normal} -test winWm-2.2 {TkpWmSetState} {pcOnly} { +test winWm-2.2 {TkpWmSetState} win { toplevel .t wm geometry .t 150x50+10+10 update @@ -114,7 +111,7 @@ test winWm-2.2 {TkpWmSetState} {pcOnly} { destroy .t set result } {normal withdrawn iconic normal} -test winWm-2.2 {TkpWmSetState} {pcOnly} { +test winWm-2.3 {TkpWmSetState} win { toplevel .t wm geometry .t 150x50+10+10 update @@ -131,7 +128,7 @@ test winWm-2.2 {TkpWmSetState} {pcOnly} { destroy .t set result } {normal withdrawn iconic normal} -test winWm-2.4 {TkpWmSetState} {pcOnly} { +test winWm-2.4 {TkpWmSetState} win { set result {} toplevel .t wm geometry .t 150x50+10+10 @@ -150,7 +147,7 @@ test winWm-2.4 {TkpWmSetState} {pcOnly} { set result } {{normal 150x50+10+10} {iconic 150x50+10+10} {iconic 150x50+10+10} {normal 200x50+10+10}} -test winWm-3.1 {ConfigureTopLevel: window geometry propagation} {pcOnly} { +test winWm-3.1 {ConfigureTopLevel: window geometry propagation} win { toplevel .t wm geometry .t +0+0 button .t.b @@ -164,38 +161,43 @@ test winWm-3.1 {ConfigureTopLevel: window geometry propagation} {pcOnly} { update pack .t.b update - set x [expr $x == [winfo x .t.b]] + set x [expr {$x == [winfo x .t.b]}] destroy .t set x } 1 -test winWm-4.1 {ConfigureTopLevel: menu resizing} {pcOnly} { +test winWm-4.1 {ConfigureTopLevel: menu resizing} win { set result {} toplevel .t - frame .t.f -width 150 -height 50 -bg red + frame .t.f -width 150 -height 50 -background red pack .t.f wm geometry .t -0-0 update set y [winfo y .t] menu .t.m .t.m add command -label foo - .t conf -menu .t.m + .t configure -menu .t.m update - set result [expr $y - [winfo y .t]] + set result [expr {$y - [winfo y .t]}] destroy .t set result -} [expr $menuheight + 1] +} [expr {$menuheight + 1}] -test winWm-5.1 {UpdateGeometryInfo: menu resizing} {pcOnly} { +# This test works on 8.0p2 but has not worked on anything since 8.2. +# It would be very strange to have a windows application increase the size +# of the clientarea when a menu wraps so I believe this test to be wrong. +# Original result was {50 50 50} new result may depend on the default menu +# font +test winWm-5.1 {UpdateGeometryInfo: menu resizing} win { set result {} toplevel .t - frame .t.f -width 150 -height 50 -bg red + frame .t.f -width 150 -height 50 -background red pack .t.f update set result [winfo height .t] menu .t.m .t.m add command -label foo - .t conf -menu .t.m + .t configure -menu .t.m update lappend result [winfo height .t] .t.m add command -label "thisisreallylong" @@ -203,25 +205,26 @@ test winWm-5.1 {UpdateGeometryInfo: menu resizing} {pcOnly} { update lappend result [winfo height .t] destroy .t + set result -} {50 50 50} -test winWm-5.2 {UpdateGeometryInfo: menu resizing} {pcOnly} { +} {50 50 31} +test winWm-5.2 {UpdateGeometryInfo: menu resizing} win { set result {} toplevel .t - frame .t.f -width 150 -height 50 -bg red + frame .t.f -width 150 -height 50 -background red pack .t.f - wm geom .t -0-0 + wm geometry .t -0-0 update set y [winfo rooty .t] lappend result [winfo height .t] menu .t.m - .t conf -menu .t.m + .t configure -menu .t.m .t.m add command -label foo .t.m add command -label "thisisreallylong" .t.m add command -label "thisisreallylong" update lappend result [winfo height .t] - lappend result [expr $y - [winfo rooty .t]] + lappend result [expr {$y - [winfo rooty .t]}] destroy .t set result } {50 50 0} @@ -230,7 +233,7 @@ test winWm-6.1 {wm attributes} win { destroy .t toplevel .t wm attributes .t -} {-alpha 1.0 -transparentcolor {} -disabled 0 -toolwindow 0 -topmost 0} +} {-alpha 1.0 -transparentcolor {} -disabled 0 -fullscreen 0 -toolwindow 0 -topmost 0} test winWm-6.2 {wm attributes} win { destroy .t toplevel .t @@ -241,7 +244,7 @@ test winWm-6.3 {wm attributes} win { destroy .t toplevel .t list [catch {wm attributes .t -foo} msg] $msg -} {1 {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}} +} {1 {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}} test winWm-6.4 {wm attributes -alpha} win { # Expect this to return all 1.0 {} on pre-2K/XP @@ -307,8 +310,8 @@ test winWm-6.8 {wm attributes -transparentcolor} win { list [catch {wm attributes .t -tr foo} msg] $msg } {1 {unknown color name "foo"}} -test winWm-7.1 {deiconify on an unmapped toplevel - will raise the window and set the focus} {pcOnly} { +test winWm-7.1 {deiconify on an unmapped toplevel\ + will raise the window and set the focus} win { destroy .t toplevel .t lower .t @@ -318,8 +321,8 @@ test winWm-7.1 {deiconify on an unmapped toplevel list [wm stackorder .t isabove .] [focus] } {1 .t} -test winWm-7.2 {deiconify on an already mapped toplevel - will raise the window and set the focus} {pcOnly} { +test winWm-7.2 {deiconify on an already mapped toplevel\ + will raise the window and set the focus} win { destroy .t toplevel .t lower .t @@ -365,8 +368,132 @@ test winWm-8.2 {Tk_WmCmd procedure, "iconphoto" option} win { image delete blank16 blank32 } {} +test winWm-9.0 "Bug #2799589 - delayed activation of destroyed window" -constraints win -setup { + proc winwm90click {w} { + if {![winfo ismapped $w]} { update } + event generate $w <Enter> + focus -force $w + event generate $w <ButtonPress-1> -x 5 -y 5 + event generate $w <ButtonRelease-1> -x 5 -y 5 + } + proc winwm90proc3 {} { + global winwm90done winwm90check + set w .sd + toplevel $w + pack [button $w.b -text "OK" -command {set winwm90check 1}] + bind $w.b <Map> {after idle {winwm90click %W}} + update idletasks + tkwait visibility $w + grab $w + tkwait variable winwm90check + grab release $w + destroy $w + after idle {set winwm90done ok} + } + proc winwm90proc2 {w} { winwm90proc3; destroy $w } + proc winwm90proc1 {w} { + toplevel $w + pack [button $w.b -text "Do dialog" -command [list winwm90proc2 $w]] + bind $w.b <Map> {bind %W <Map> {}; after idle {winwm90click %W}} + } + destroy .t + global winwm90done + set winwm90done wait + toplevel .t +} -body { + pack [button .t.b -text "Show" -command {winwm90proc1 .tx}] + bind .t.b <Map> {bind %W <Map> {}; after idle {winwm90click %W}} + after 5000 {set winwm90done timeout} + vwait winwm90done + set winwm90done +} -cleanup { + foreach cmd {proc1 proc2 proc3 click} { + rename winwm90$cmd {} + } + destroy .tx .t .sd +} -result {ok} + +test winWm-9.1 "delayed activation of grabbed destroyed window" -constraints win -setup { + proc winwm91click {w} { + if {![winfo ismapped $w]} { update } + event generate $w <Enter> + focus -force $w + event generate $w <ButtonPress-1> -x 5 -y 5 + event generate $w <ButtonRelease-1> -x 5 -y 5 + } + proc winwm91proc3 {} { + global winwm91done winwm91check + set w .sd + toplevel $w + pack [button $w.b -text "OK" -command {set winwm91check 1}] + bind $w.b <Map> {after idle {winwm91click %W}} + update idletasks + tkwait visibility $w + grab $w + tkwait variable winwm91check + #skip the release: #grab release $w + destroy $w + after idle {set winwm91done ok} + } + proc winwm91proc2 {w} { winwm91proc3; destroy $w } + proc winwm91proc1 {w} { + toplevel $w + pack [button $w.b -text "Do dialog" -command [list winwm91proc2 $w]] + bind $w.b <Map> {bind %W <Map> {}; after idle {winwm91click %W}} + } + destroy .t + global winwm91done + set winwm91done wait + toplevel .t +} -body { + pack [button .t.b -text "Show" -command {winwm91proc1 .tx}] + bind .t.b <Map> {bind %W <Map> {}; after idle {winwm91click %W}} + after 5000 {set winwm91done timeout} + vwait winwm91done + set winwm91done +} -cleanup { + foreach cmd {proc1 proc2 proc3 click} { + rename winwm91$cmd {} + } + destroy .tx .t .sd +} -result {ok} + +test winWm-9.2 "check wm forget for unmapped parent (#3205464,#2967911)" -setup { + destroy .t + toplevel .t + set winwm92 {} + frame .t.f -background blue -height 200 -width 200 + frame .t.f.x -background red -height 100 -width 100 +} -body { + pack .t.f.x + pack .t.f + set aid [after 1000 {set ::winwm92 timeout}] + after 100 { + wm manage .t.f + wm iconify .t + after 100 { + wm forget .t.f + wm deiconify .t + after 100 { + pack .t.f + after 100 {set ::winwm92 [expr {[winfo rooty .t.f.x] == 0 ? "failed" : "ok"}]} + } + } + } + vwait ::winwm92 + after cancel $aid + set winwm92 +} -cleanup { + destroy .t.f.x .t.f .t + unset -nocomplain winwm92 aid +} -result ok + destroy .t # cleanup -::tcltest::cleanupTests +cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/window.test b/tests/window.test index 8628c7a..2c8f19d 100644 --- a/tests/window.test +++ b/tests/window.test @@ -6,15 +6,12 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -namespace import -force tcltest::interpreter -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands - +testConstraint unthreaded [expr { + (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded)) +}] +namespace import -force ::tk::test::loadTkCommand update # XXX This file is woefully incomplete. Right now it only tests @@ -80,59 +77,84 @@ test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { update bind . <Destroy> exit destroy . - } script] - set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg] + } + set script [makeFile $code script] + if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } removeFile script list $error $msg } {0 {}} test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t update bind .t <Destroy> exit destroy .t - } script] - set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg] + } + set script [makeFile $code script] + if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } removeFile script list $error $msg } {0 {}} test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t update bind .t <Destroy> exit destroy . - } script] - set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg] + } + set script [makeFile $code script] + if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } removeFile script list $error $msg } {0 {}} test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t toplevel .t.f update bind .t.f <Destroy> exit destroy . - } script] - set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg] + } + set script [makeFile $code script] + if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } removeFile script list $error $msg } {0 {}} test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t1 toplevel .t2 toplevel .t3 @@ -141,30 +163,44 @@ test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \ bind .t2 <Destroy> {destroy .t1} bind .t1 <Destroy> {exit 0} destroy .t3 - } script] - set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg] + } + set script [makeFile $code script] + if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } removeFile script list $error $msg } {0 {}} -test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} \ - unixOrWin { - set script [makeFile { +# window-2.9 deadlocks threaded Tk [Bug 1715716] +test window-2.9 {Tk_DestroyWindow, Destroy bindings + evaluated after exit} {unixOrWin unthreaded} { + set code [loadTkCommand] + append code { toplevel .t1 toplevel .t2 update bind .t2 <Destroy> {puts "Destroy .t2" ; exit 1} bind .t1 <Destroy> {puts "Destroy .t1" ; exit 0} destroy .t2 - } script] - set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg] + } + set script [makeFile $code script] + if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } removeFile script list $error $msg } {0 {Destroy .t2 Destroy .t1}} -test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} unixOrWin { - set script [makeFile { +test window-2.10 {Tk_DestroyWindow, Destroy binding + evaluated once} unixOrWin { + set code [loadTkCommand] + append code { update bind . <Destroy> { puts "Destroy ." @@ -172,15 +208,21 @@ test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} unixOrWin { exit 0 } destroy . - } script] - set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg] + } + set script [makeFile $code script] + if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } removeFile script list $error $msg } {0 {Destroy .}} test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t1 toplevel .t2 update @@ -193,17 +235,19 @@ test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \ } bind .t2 <Destroy> {exit} destroy .t2 - } script] - set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg] + } + set script [makeFile $code script] + if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } removeFile script list $error $msg } {0 YES} -# Some tests require the testmenubar command -testConstraint testmenubar [llength [info commands testmenubar]] - test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ - {unixOnly testmenubar} { + {unix testmenubar} { catch {destroy .t} toplevel .t -width 300 -height 200 wm geometry .t +0+0 @@ -214,7 +258,7 @@ test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ # If stacking order isn't handle properly, generates an X error. } {} test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \ - {unixOnly testmenubar} { + {unix testmenubar} { catch {destroy .t} toplevel .t -width 300 -height 200 wm geometry .t +0+0 @@ -241,7 +285,7 @@ test window-4.2 {Tk_NameToWindow procedure} {testmenubar} { } {0 100x50+10+10} test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ - {unixOnly testmenubar} { + {unix testmenubar} { catch {destroy .t} toplevel .t -width 300 -height 200 wm geometry .t +0+0 @@ -256,17 +300,5 @@ test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ } {} # cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - diff --git a/tests/winfo.test b/tests/winfo.test index b69de55..4ce87eb 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -7,10 +7,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands # eatColors -- @@ -82,20 +79,16 @@ test winfo-2.7 {"winfo atom" command} { winfo atomname -displayof . 2 } SECONDARY -# Some tests require the "pseudocolor" visual class. -testConstraint pseudocolor [expr { ([winfo depth .] == 8) - && ([winfo visual .] == "pseudocolor")}] - -test winfo-3.1 {"winfo colormapfull" command} {pseudocolor} { +test winfo-3.1 {"winfo colormapfull" command} defaultPseudocolor8 { list [catch {winfo colormapfull} msg] $msg } {1 {wrong # args: should be "winfo colormapfull window"}} -test winfo-3.2 {"winfo colormapfull" command} {pseudocolor} { +test winfo-3.2 {"winfo colormapfull" command} defaultPseudocolor8 { list [catch {winfo colormapfull a b} msg] $msg } {1 {wrong # args: should be "winfo colormapfull window"}} -test winfo-3.3 {"winfo colormapfull" command} {pseudocolor} { +test winfo-3.3 {"winfo colormapfull" command} defaultPseudocolor8 { list [catch {winfo colormapfull foo} msg] $msg } {1 {bad window path name "foo"}} -test winfo-3.4 {"winfo colormapfull" command} {macOrUnix pseudocolor} { +test winfo-3.4 {"winfo colormapfull" command} {unix defaultPseudocolor8} { eatColors .t {-colormap new} set result [list [winfo colormapfull .] [winfo colormapfull .t]] .t.c delete 34 @@ -113,8 +106,7 @@ toplevel .t -width 550 -height 400 frame .t.f -width 80 -height 60 -bd 2 -relief raised place .t.f -x 50 -y 50 wm geom .t +0+0 -tkwait visibility .t.f - +update test winfo-4.1 {"winfo containing" command} { list [catch {winfo containing 22} msg] $msg } {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}} @@ -128,6 +120,7 @@ test winfo-4.4 {"winfo containing" command} { list [catch {winfo containing -displayof geek 25 30} msg] $msg } {1 {bad window path name "geek"}} test winfo-4.5 {"winfo containing" command} { + raise .t winfo containing [winfo rootx .t.f] [winfo rooty .t.f] } .t.f test winfo-4.6 {"winfo containing" command} {nonPortable} { @@ -149,10 +142,10 @@ test winfo-5.2 {"winfo interps" command} { test winfo-5.3 {"winfo interps" command} { list [catch {winfo interps -displayof geek} msg] $msg } {1 {bad window path name "geek"}} -test winfo-5.4 {"winfo interps" command} {unixOnly} { +test winfo-5.4 {"winfo interps" command} unix { expr [lsearch -exact [winfo interps] [tk appname]] >= 0 } {1} -test winfo-5.5 {"winfo interps" command} {unixOnly} { +test winfo-5.5 {"winfo interps" command} unix { expr [lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0 } {1} @@ -202,7 +195,7 @@ test winfo-7.6 {"winfo pathname" command} { test winfo-7.7 {"winfo pathname" command} { winfo pathname -displayof .b [winfo id .] } {.} -test winfo-7.8 {"winfo pathname" command} {unixOnly testwrapper} { +test winfo-7.8 {"winfo pathname" command} {unix testwrapper} { winfo pathname [testwrapper .] } {} @@ -371,5 +364,5 @@ test winfo-14.4 {mapped at idle time} { deleteWindows # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/wm.test b/tests/wm.test index 649e3df..15526e7 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -1,21 +1,18 @@ -# This file is a Tcl script to test out Tk's interactions with -# the window manager, including the "wm" command. It is organized -# in the standard fashion for Tcl tests. +# This file is a Tcl script to test out Tk's interactions with the window +# manager, including the "wm" command. It is organized in the standard fashion +# for Tcl tests. # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -# This file tests window manager interactions that work across -# platforms. Window manager tests that only work on a specific -# platform should be placed in unixWm.test or winWm.test. +# This file tests window manager interactions that work across platforms. +# Window manager tests that only work on a specific platform should be placed +# in unixWm.test or winWm.test. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands wm deiconify . @@ -30,160 +27,439 @@ proc stdWindow {} { update } -# [raise] and [lower] may return before the window manager -# has completed the operation. The raiseDelay procedure -# idles for a while to give the operation a chance to complete. +# [raise] and [lower] may return before the window manager has completed the +# operation. The raiseDelay procedure idles for a while to give the operation +# a chance to complete. # proc raiseDelay {} { after 100; update } +# How to carry out a small delay while processing events -deleteWindows -stdWindow - -test wm-1.1 {Tk_WmObjCmd procedure, miscellaneous errors} { - list [catch {wm} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +proc eventDelay {{delay 200}} { + after $delay "set done 1" ; vwait done +} -test wm-1.2 {Tk_WmObjCmd procedure, miscellaneous errors} { - list [catch {wm foo} msg] $msg -} {1 {bad option "foo": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}} +deleteWindows -test wm-1.3 {Tk_WmObjCmd procedure, miscellaneous errors} { - list [catch {wm command} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +############################################################################## -test wm-1.4 {Tk_WmObjCmd procedure, miscellaneous errors} { - list [catch {wm aspect bogus} msg] $msg -} {1 {bad window path name "bogus"}} +stdWindow -test wm-1.5 {Tk_WmObjCmd procedure, miscellaneous errors} { - catch {destroy .b} +test wm-1.1 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { + wm +} -result {wrong # args: should be "wm option window ?arg ...?"} +# Next test will fail every time set of subcommands is changed +test wm-1.2 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { + wm foo +} -result {bad option "foo": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw} +test wm-1.3 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { + wm command +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-1.4 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { + wm aspect bogus +} -result {bad window path name "bogus"} +test wm-1.5 {Tk_WmObjCmd procedure, miscellaneous errors} -body { button .b -text hello - list [catch {wm geometry .b} msg] $msg -} {1 {window ".b" isn't a top-level window}} - - -test wm-aspect-1.1 {usage} { - list [catch {wm aspect} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-aspect-1.2 {usage} { - list [catch {wm aspect . _} err] $err -} {1 {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}} - -test wm-aspect-1.3 {usage} { - list [catch {wm aspect . _ _ _} err] $err -} {1 {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}} - -test wm-aspect-1.4 {usage} { - list [catch {wm aspect . _ _ _ _ _} err] $err -} {1 {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}} - -test wm-aspect-1.5 {usage} { - list [catch {wm aspect . bad 14 15 16} msg] $msg -} {1 {expected integer but got "bad"}} - -test wm-aspect-1.6 {usage} { - list [catch {wm aspect . 13 foo 15 16} msg] $msg -} {1 {expected integer but got "foo"}} - -test wm-aspect-1.7 {usage} { - list [catch {wm aspect . 13 14 bar 16} msg] $msg -} {1 {expected integer but got "bar"}} - -test wm-aspect-1.8 {usage} { - list [catch {wm aspect . 13 14 15 baz} msg] $msg -} {1 {expected integer but got "baz"}} - -test wm-aspect-1.9 {usage} { - list [catch {wm aspect . 0 14 15 16} msg] $msg -} {1 {aspect number can't be <= 0}} - -test wm-aspect-1.10 {usage} { - list [catch {wm aspect . 13 0 15 16} msg] $msg -} {1 {aspect number can't be <= 0}} - -test wm-aspect-1.11 {usage} { - list [catch {wm aspect . 13 14 0 16} msg] $msg -} {1 {aspect number can't be <= 0}} - -test wm-aspect-1.12 {usage} { - list [catch {wm aspect . 13 14 15 0} msg] $msg -} {1 {aspect number can't be <= 0}} - -test wm-aspect-2.1 {setting and reading values} { + wm geometry .b +} -returnCodes error -cleanup { + destroy .b +} -result {window ".b" isn't a top-level window} + + +### wm aspect ### +test wm-aspect-1.1 {usage} -returnCodes error -body { + wm aspect +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-aspect-1.2 {usage} -returnCodes error -body { + wm aspect . _ +} -result {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"} +test wm-aspect-1.3 {usage} -returnCodes error -body { + wm aspect . _ _ _ +} -result {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"} +test wm-aspect-1.4 {usage} -returnCodes error -body { + wm aspect . _ _ _ _ _ +} -result {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"} +test wm-aspect-1.5 {usage} -returnCodes error -body { + wm aspect . bad 14 15 16 +} -result {expected integer but got "bad"} +test wm-aspect-1.6 {usage} -returnCodes error -body { + wm aspect . 13 foo 15 16 +} -result {expected integer but got "foo"} +test wm-aspect-1.7 {usage} -returnCodes error -body { + wm aspect . 13 14 bar 16 +} -result {expected integer but got "bar"} +test wm-aspect-1.8 {usage} -returnCodes error -body { + wm aspect . 13 14 15 baz +} -result {expected integer but got "baz"} +test wm-aspect-1.9 {usage} -returnCodes error -body { + wm aspect . 0 14 15 16 +} -result {aspect number can't be <= 0} +test wm-aspect-1.10 {usage} -returnCodes error -body { + wm aspect . 13 0 15 16 +} -result {aspect number can't be <= 0} +test wm-aspect-1.11 {usage} -returnCodes error -body { + wm aspect . 13 14 0 16 +} -result {aspect number can't be <= 0} +test wm-aspect-1.12 {usage} -returnCodes error -body { + wm aspect . 13 14 15 0 +} -result {aspect number can't be <= 0} + +test wm-aspect-2.1 {setting and reading values} -setup { set result {} +} -body { lappend result [wm aspect .t] wm aspect .t 3 4 10 2 lappend result [wm aspect .t] wm aspect .t {} {} {} {} lappend result [wm aspect .t] -} [list {} {3 4 10 2} {}] - - -test wm-attributes-1.1 {usage} { - list [catch {wm attributes} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +} -result [list {} {3 4 10 2} {}] + + +### wm attributes ### +test wm-attributes-1.1 {usage} -returnCodes error -body { + wm attributes +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-attributes-1.2.1 {usage} -constraints win -returnCodes error -body { + # This is the wrong error to output - unix has it right, but it's + # not critical. + wm attributes . _ +} -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"} +test wm-attributes-1.2.2 {usage} -constraints win -returnCodes error -body { + wm attributes . -alpha 1.0 -disabled +} -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"} +test wm-attributes-1.2.3 {usage} -constraints win -returnCodes error -body { + # This is the wrong error to output - unix has it right, but it's + # not critical. + wm attributes . -to +} -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"} +test wm-attributes-1.2.4 {usage} -constraints {unix notAqua} -returnCodes error -body { + wm attributes . _ +} -result {bad attribute "_": must be -alpha, -topmost, -zoomed, -fullscreen, or -type} +test wm-attributes-1.2.5 {usage} -constraints aqua -returnCodes error -body { + wm attributes . _ +} -result {bad attribute "_": must be -alpha, -modified, -notify, or -titlepath} + + +### wm client ### +test wm-client-1.1 {usage} -returnCodes error -body { + wm client +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-client-1.2 {usage} -returnCodes error -body { + wm client . _ _ +} -result {wrong # args: should be "wm client window ?name?"} + +test wm-client-2.1 {setting and reading values} -setup { + set result {} +} -body { + lappend result [wm client .t] + wm client .t Miffo + lappend result [wm client .t] + wm client .t {} + lappend result [wm client .t] +} -result [list {} Miffo {}] -test wm-attributes-1.2.1 {usage} {pcOnly} { - list [catch {wm attributes . _} err] $err -} {1 {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}} +deleteWindows -test wm-attributes-1.2.2 {usage} {pcOnly} { - list [catch {wm attributes . -alpha 1.0 -disabled} err] $err -} {1 {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}} +test wm-attributes-1.3.0 {default -fullscreen value} -constraints win -body { + toplevel .t + wm attributes .t -fullscreen +} -cleanup { + deleteWindows +} -result 0 +test wm-attributes-1.3.1 {change -fullscreen before map} -constraints win -body { + toplevel .t + wm attributes .t -fullscreen 1 + wm attributes .t -fullscreen +} -cleanup { + deleteWindows +} -result 1 +test wm-attributes-1.3.2 {change -fullscreen before map} -constraints win -body { + toplevel .t + wm attributes .t -fullscreen 1 + update + wm attributes .t -fullscreen +} -cleanup { + deleteWindows +} -result 1 +test wm-attributes-1.3.3 {change -fullscreen after map} -constraints win -body { + toplevel .t + update + wm attributes .t -fullscreen 1 + wm attributes .t -fullscreen +} -cleanup { + deleteWindows +} -result 1 +test wm-attributes-1.3.4 {change -fullscreen after map} -setup { + set booleans [list] +} -constraints win -body { + toplevel .t + update + lappend booleans [wm attributes .t -fullscreen] + wm attributes .t -fullscreen 1 + lappend booleans [wm attributes .t -fullscreen] + # Query above should not clear fullscreen state + lappend booleans [wm attributes .t -fullscreen] + wm attributes .t -fullscreen 0 + lappend booleans [wm attributes .t -fullscreen] +} -cleanup { + deleteWindows +} -result {0 1 1 0} +test wm-attributes-1.3.5 {change -fullscreen after map} -setup { + set results [list] + set normal_geom "301x302+101+102" + set fullscreen_geom "[winfo screenwidth .]x[winfo screenheight .]+0+0" +} -constraints win -body { + toplevel .t + wm geom .t $normal_geom + update + lappend results [string equal [wm geom .t] $normal_geom] + wm attributes .t -fullscreen 1 + lappend results [string equal [wm geom .t] $fullscreen_geom] + wm attributes .t -fullscreen 0 + lappend results [string equal [wm geom .t] $normal_geom] +} -cleanup { + deleteWindows +} -result {1 1 1} +test wm-attributes-1.3.6 {state change does not change -fullscreen} -constraints win -body { + toplevel .t + update + wm attributes .t -fullscreen 1 + wm withdraw .t + wm deiconify .t + wm attributes .t -fullscreen +} -cleanup { + deleteWindows +} -result 1 +test wm-attributes-1.3.7 {state change does not change -fullscreen} -constraints win -body { + toplevel .t + update + wm attributes .t -fullscreen 1 + wm iconify .t + wm deiconify .t + wm attributes .t -fullscreen +} -cleanup { + deleteWindows +} -result 1 +test wm-attributes-1.3.8 {override-redirect not compatible with fullscreen attribute} -constraints win -body { + toplevel .t + update + wm overrideredirect .t 1 + wm attributes .t -fullscreen 1 +} -returnCodes error -cleanup { + deleteWindows +} -result {can't set fullscreen attribute for ".t": override-redirect flag is set} +test wm-attributes-1.3.9 {max height too small} -constraints win -body { + toplevel .t + update + wm maxsize .t 5000 450 + wm attributes .t -fullscreen 1 +} -returnCodes error -cleanup { + deleteWindows +} -result {can't set fullscreen attribute for ".t": max width/height is too small} +test wm-attributes-1.3.10 {max height too small} -constraints win -body { + toplevel .t + update + wm maxsize .t 450 5000 + wm attributes .t -fullscreen 1 +} -returnCodes error -cleanup { + deleteWindows +} -result {can't set fullscreen attribute for ".t": max width/height is too small} +test wm-attributes-1.3.11 {another attribute, then -fullscreen} -constraints win -body { + toplevel .t + update + wm attributes .t -alpha 1.0 -fullscreen 1 + wm attributes .t -fullscreen +} -cleanup { + deleteWindows +} -result 1 +test wm-attributes-1.3.12 {another attribute, then -fullscreen, then another} -constraints win -body { + toplevel .t + update + wm attributes .t -toolwindow 0 -fullscreen 1 -topmost 0 + wm attributes .t -fullscreen +} -cleanup { + deleteWindows +} -result 1 -test wm-attributes-1.2.3 {usage} {pcOnly} { - list [catch {wm attributes . -to} err] $err -} {1 {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}} +test wm-attributes-1.4.0 {setting/unsetting fullscreen does not change the focus} -setup { + set results [list] +} -constraints win -body { + focus -force . + toplevel .t + lower .t + update + lappend results [focus] -test wm-attributes-1.2.4 {usage} {macOrUnix notAqua} { - list [catch {wm attributes . _} err] $err -} {1 {wrong # args: should be "wm attributes window ?-type list?"}} + wm attributes .t -fullscreen 1 + eventDelay + lappend results [focus] -test wm-attributes-1.2.5 {usage} {aqua} { - list [catch {wm attributes . _} err] $err -} {1 {bad attribute "_": must be -alpha, -modified, or -titlepath}} + wm attributes .t -fullscreen 0 + eventDelay + lappend results [focus] +} -cleanup { + deleteWindows +} -result {. . .} +test wm-attributes-1.4.1 {setting fullscreen does not generate FocusIn on wrapper create} -setup { + catch {unset focusin} +} -constraints win -body { + focus -force . + toplevel .t + pack [entry .t.e] + lower .t + bind .t <FocusIn> {lappend focusin %W} + eventDelay -test wm-client-1.1 {usage} { - list [catch {wm client} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} + lappend focusin 1 + focus -force .t.e + eventDelay -test wm-client-1.2 {usage} { - list [catch {wm client . _ _} err] $err -} {1 {wrong # args: should be "wm client window ?name?"}} + lappend focusin 2 + wm attributes .t -fullscreen 1 + eventDelay -test wm-client-2.1 {setting and reading values} { - set result {} - lappend result [wm client .t] - wm client .t Miffo - lappend result [wm client .t] - wm client .t {} - lappend result [wm client .t] -} [list {} Miffo {}] + lappend focusin 3 + wm attributes .t -fullscreen 0 + eventDelay + lappend focusin final [focus] +} -cleanup { + bind . <FocusIn> {} + bind .t <FocusIn> {} + deleteWindows +} -result {1 .t .t.e 2 3 final .t.e} -test wm-colormapwindows-1.1 {usage} { - list [catch {wm colormapwindows} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +test wm-attributes-1.5.0 {fullscreen stackorder} -setup { + set results [list] +} -constraints win -body { + toplevel .t + lappend results [wm stackorder .] + eventDelay + lappend results [wm stackorder .] + + # Default stacking is on top of other windows on the display. Setting the + # fullscreen attribute does not change this. + wm attributes .t -fullscreen 1 + eventDelay + lappend results [wm stackorder .] +} -cleanup { + deleteWindows +} -result {. {. .t} {. .t}} +test wm-attributes-1.5.1 {fullscreen stackorder} -setup { + set results [list] +} -constraints win -body { + toplevel .t + lower .t + eventDelay + lappend results [wm stackorder .] + + # If stacking order is explicitly set, then setting the fullscreen + # attribute should not change it. + wm attributes .t -fullscreen 1 + eventDelay + lappend results [wm stackorder .] +} -cleanup { + deleteWindows +} -result {{.t .} {.t .}} +test wm-attributes-1.5.2 {fullscreen stackorder} -setup { + set results [list] +} -constraints win -body { + toplevel .t + # lower forces the window to be mapped, it would not be otherwise + lower .t + lappend results [wm stackorder .] + + # If stacking order is explicitly set for an unmapped window, then setting + # the fullscreen attribute should not change it. + wm attributes .t -fullscreen 1 + eventDelay + lappend results [wm stackorder .] +} -cleanup { + deleteWindows +} -result {{.t .} {.t .}} +test wm-attributes-1.5.3 {fullscreen stackorder} -setup { + set results [list] +} -constraints win -body { + toplevel .t + eventDelay + lappend results [wm stackorder .] + + wm attributes .t -fullscreen 1 + eventDelay + lappend results [wm stackorder .] + + # Unsetting the fullscreen attribute should not change the stackorder. + wm attributes .t -fullscreen 0 + eventDelay + lappend results [wm stackorder .] +} -cleanup { + deleteWindows +} -result {{. .t} {. .t} {. .t}} +test wm-attributes-1.5.4 {fullscreen stackorder} -setup { + set results [list] +} -constraints win -body { + toplevel .t + lower .t + eventDelay + lappend results [wm stackorder .] + + wm attributes .t -fullscreen 1 + eventDelay + lappend results [wm stackorder .] + + # Unsetting the fullscreen attribute should not change the stackorder. + wm attributes .t -fullscreen 0 + eventDelay + lappend results [wm stackorder .] +} -cleanup { + deleteWindows +} -result {{.t .} {.t .} {.t .}} +test wm-attributes-1.5.5 {fullscreen stackorder} -setup { + set results [list] +} -constraints win -body { + toplevel .a + toplevel .b + toplevel .c + raise .a + raise .b + raise .c + eventDelay + lappend results [wm stackorder .] + + wm attributes .b -fullscreen 1 + eventDelay + lappend results [wm stackorder .] + + # Unsetting the fullscreen attribute should not change the stackorder. + wm attributes .b -fullscreen 0 + eventDelay + lappend results [wm stackorder .] +} -cleanup { + deleteWindows +} -result {{. .a .b .c} {. .a .b .c} {. .a .b .c}} -test wm-colormapwindows-1.2 {usage} { - list [catch {wm colormapwindows . _ _} err] $err -} {1 {wrong # args: should be "wm colormapwindows window ?windowList?"}} -test wm-colormapwindows-1.3 {usage} { - list [catch {wm colormapwindows . "a \{"} msg] $msg -} {1 {unmatched open brace in list}} +stdWindow -test wm-colormapwindows-1.4 {usage} { - list [catch {wm colormapwindows . foo} msg] $msg -} {1 {bad window path name "foo"}} -test wm-colormapwindows-2.1 {reading values} { - catch {destroy .t2} +### wm colormapwindows ### +test wm-colormapwindows-1.1 {usage} -returnCodes error -body { + wm colormapwindows +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-colormapwindows-1.2 {usage} -returnCodes error -body { + wm colormapwindows . _ _ +} -result {wrong # args: should be "wm colormapwindows window ?windowList?"} +test wm-colormapwindows-1.3 {usage} -returnCodes error -body { + wm colormapwindows . "a \{" +} -result {unmatched open brace in list} +test wm-colormapwindows-1.4 {usage} -returnCodes error -body { + wm colormapwindows . foo +} -result {bad window path name "foo"} + +test wm-colormapwindows-2.1 {reading values} -body { toplevel .t2 -width 200 -height 200 -colormap new wm geom .t2 +0+0 frame .t2.a -width 100 -height 30 @@ -195,10 +471,10 @@ test wm-colormapwindows-2.1 {reading values} { pack .t2.c -side top update list $x [wm colormapwindows .t2] -} {{.t2.b .t2} {.t2.b .t2.c .t2}} - -test wm-colormapwindows-2.2 {setting and reading values} { - catch {destroy .t2} +} -cleanup { + destroy .t2 +} -result {{.t2.b .t2} {.t2.b .t2.c .t2}} +test wm-colormapwindows-2.2 {setting and reading values} -body { toplevel .t2 -width 200 -height 200 wm geom .t2 +0+0 frame .t2.a -width 100 -height 30 @@ -207,84 +483,97 @@ test wm-colormapwindows-2.2 {setting and reading values} { pack .t2.a .t2.b .t2.c -side top wm colormapwindows .t2 {.t2.b .t2.a} wm colormapwindows .t2 -} {.t2.b .t2.a} - - -test wm-command-1.1 {usage} { - list [catch {wm command} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +} -cleanup { + destroy .t2 +} -result {.t2.b .t2.a} -test wm-command-1.2 {usage} { - list [catch {wm command . _ _} err] $err -} {1 {wrong # args: should be "wm command window ?value?"}} -test wm-command-1.3 {usage} { - list [catch {wm command . "a \{"} msg] $msg -} {1 {unmatched open brace in list}} +### wm command ### +test wm-command-1.1 {usage} -returnCodes error -body { + wm command +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-command-1.2 {usage} -returnCodes error -body { + wm command . _ _ +} -result {wrong # args: should be "wm command window ?value?"} +test wm-command-1.3 {usage} -returnCodes error -body { + wm command . "a \{" +} -result {unmatched open brace in list} -test wm-command-2.1 {setting and reading values} { +test wm-command-2.1 {setting and reading values} -setup { set result {} +} -body { lappend result [wm command .t] wm command .t [list Miffo Foo] lappend result [wm command .t] wm command .t {} lappend result [wm command .t] -} [list {} [list Miffo Foo] {}] - - -test wm-deiconify-1.1 {usage} { - list [catch {wm deiconify} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-deiconify-1.2 {usage} { - list [catch {wm deiconify . _} err] $err -} {1 {wrong # args: should be "wm deiconify window"}} - -test wm-deiconify-1.3 {usage} { - list [catch {wm deiconify _} err] $err -} {1 {bad window path name "_"}} - -test wm-deiconify-1.4 {usage} { - catch {destroy .icon} +} -result [list {} [list Miffo Foo] {}] + + +### wm deiconify ### +test wm-deiconify-1.1 {usage} -returnCodes error -body { + wm deiconify +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-deiconify-1.2 {usage} -returnCodes error -body { + wm deiconify . _ +} -result {wrong # args: should be "wm deiconify window"} +test wm-deiconify-1.3 {usage} -returnCodes error -body { + wm deiconify _ +} -result {bad window path name "_"} +test wm-deiconify-1.4 {usage} -setup { + destroy .icon +} -body { toplevel .icon -width 50 -height 50 -bg red wm iconwindow .t .icon - set result [list [catch {wm deiconify .icon} msg] $msg] + wm deiconify .icon +} -returnCodes error -cleanup { destroy .icon - set result -} {1 {can't deiconify .icon: it is an icon for .t}} - -test wm-deiconify-1.5 {usage} { - catch {destroy .embed} +} -result {can't deiconify .icon: it is an icon for .t} +# test embedded window for Windows +test wm-deiconify-1.5 {usage} -constraints win -setup { + destroy .embed +} -body { + frame .t.f -container 1 + toplevel .embed -use [winfo id .t.f] + wm deiconify .embed +} -returnCodes error -cleanup { + destroy .t.f .embed +} -result {can't deiconify .embed: the container does not support the request} +# test embedded window for other platforms +test wm-deiconify-1.6 {usage} -constraints !win -setup { + destroy .embed +} -body { frame .t.f -container 1 toplevel .embed -use [winfo id .t.f] - set result [list [catch {wm deiconify .embed} msg] $msg] + wm deiconify .embed +} -returnCodes error -cleanup { destroy .t.f .embed - set result -} {1 {can't deiconify .embed: it is an embedded window}} +} -result {can't deiconify .embed: it is an embedded window} -test wm-deiconify-2.1 {a window that has never been mapped - should not be mapped by a call to deiconify} { - deleteWindows +deleteWindows +test wm-deiconify-2.1 {a window that has never been mapped\ + should not be mapped by a call to deiconify} -body { toplevel .t wm deiconify .t winfo ismapped .t -} 0 - -test wm-deiconify-2.2 {a window that has already been - mapped should be mapped by deiconify} { +} -cleanup { deleteWindows +} -result 0 +test wm-deiconify-2.2 {a window that has already been\ + mapped should be mapped by deiconify} -body { toplevel .t update idletasks wm withdraw .t wm deiconify .t winfo ismapped .t -} 1 - -test wm-deiconify-2.3 {geometry for an unmapped window - should not be calculated by a call to deiconify, - it should be done at idle time} { +} -cleanup { deleteWindows +} -result 1 +test wm-deiconify-2.3 {geometry for an unmapped window\ + should not be calculated by a call to deiconify,\ + it should be done at idle time} -setup { set results {} +} -body { toplevel .t -width 200 -height 200 lappend results [wm geometry .t] wm deiconify .t @@ -292,235 +581,231 @@ test wm-deiconify-2.3 {geometry for an unmapped window update idletasks lappend results [lindex [split \ [wm geometry .t] +] 0] -} {1x1+0+0 1x1+0+0 200x200} - -test wm-deiconify-2.4 {invoking destroy after a deiconify - should not result in a crash because of a callback - set on the toplevel} { +} -cleanup { deleteWindows +} -result {1x1+0+0 1x1+0+0 200x200} +test wm-deiconify-2.4 {invoking destroy after a deiconify\ + should not result in a crash because of a callback\ + set on the toplevel} -body { toplevel .t wm withdraw .t wm deiconify .t destroy .t update -} {} - - -test wm-focusmodel-1.1 {usage} { - list [catch {wm focusmodel} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +} -cleanup { + deleteWindows +} -test wm-focusmodel-1.2 {usage} { - list [catch {wm focusmodel . _ _} err] $err -} {1 {wrong # args: should be "wm focusmodel window ?active|passive?"}} -test wm-focusmodel-1.3 {usage} { - list [catch {wm focusmodel . bogus} msg] $msg -} {1 {bad argument "bogus": must be active or passive}} +### wm focusmodel ### +test wm-focusmodel-1.1 {usage} -returnCodes error -body { + wm focusmodel +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-focusmodel-1.2 {usage} -returnCodes error -body { + wm focusmodel . _ _ +} -result {wrong # args: should be "wm focusmodel window ?active|passive?"} +test wm-focusmodel-1.3 {usage} -returnCodes error -body { + wm focusmodel . bogus +} -result {bad argument "bogus": must be active or passive} stdWindow -test wm-focusmodel-2.1 {setting and reading values} { - set result {} +test wm-focusmodel-2.1 {setting and reading values} -setup { + set result {} +} -body { lappend result [wm focusmodel .t] wm focusmodel .t active lappend result [wm focusmodel .t] wm focusmodel .t passive lappend result [wm focusmodel .t] - set result -} {passive active passive} - - -test wm-frame-1.1 {usage} { - list [catch {wm frame} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-frame-1.2 {usage} { - list [catch {wm frame . _} err] $err -} {1 {wrong # args: should be "wm frame window"}} - - -test wm-geometry-1.1 {usage} { - list [catch {wm geometry} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-geometry-1.2 {usage} { - list [catch {wm geometry . _ _} err] $err -} {1 {wrong # args: should be "wm geometry window ?newGeometry?"}} - -test wm-geometry-1.3 {usage} { - list [catch {wm geometry . bogus} msg] $msg -} {1 {bad geometry specifier "bogus"}} - -test wm-geometry-2.1 {setting values} { +} -result {passive active passive} + + +### wm frame ### +test wm-frame-1.1 {usage} -returnCodes error -body { + wm frame +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-frame-1.2 {usage} -returnCodes error -body { + wm frame . _ +} -result {wrong # args: should be "wm frame window"} + + +### wm geometry ### +test wm-geometry-1.1 {usage} -returnCodes error -body { + wm geometry +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-geometry-1.2 {usage} -returnCodes error -body { + wm geometry . _ _ +} -result {wrong # args: should be "wm geometry window ?newGeometry?"} +test wm-geometry-1.3 {usage} -returnCodes error -body { + wm geometry . bogus +} -result {bad geometry specifier "bogus"} + +test wm-geometry-2.1 {setting values} -setup { set result {} +} -body { wm geometry .t 150x150+50+50 update lappend result [wm geometry .t] wm geometry .t {} update lappend result [string equal [wm geometry .t] "150x150+50+50"] -} [list 150x150+50+50 0] - - -test wm-grid-1.1 {usage} { - list [catch {wm grid} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-grid-1.2 {usage} { - list [catch {wm grid . _} err] $err -} {1 {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}} - -test wm-grid-1.3 {usage} { - list [catch {wm grid . _ _ _} err] $err -} {1 {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}} - -test wm-grid-1.4 {usage} { - list [catch {wm grid . _ _ _ _ _} err] $err -} {1 {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}} - -test wm-grid-1.5 {usage} { - list [catch {wm grid . bad 14 15 16} msg] $msg -} {1 {expected integer but got "bad"}} - -test wm-grid-1.6 {usage} { - list [catch {wm grid . 13 foo 15 16} msg] $msg -} {1 {expected integer but got "foo"}} - -test wm-grid-1.7 {usage} { - list [catch {wm grid . 13 14 bar 16} msg] $msg -} {1 {expected integer but got "bar"}} - -test wm-grid-1.8 {usage} { - list [catch {wm grid . 13 14 15 baz} msg] $msg -} {1 {expected integer but got "baz"}} - -test wm-grid-1.9 {usage} { - list [catch {wm grid . -1 14 15 16} msg] $msg -} {1 {baseWidth can't be < 0}} - -test wm-grid-1.10 {usage} { - list [catch {wm grid . 13 -1 15 16} msg] $msg -} {1 {baseHeight can't be < 0}} - -test wm-grid-1.11 {usage} { - list [catch {wm grid . 13 14 -1 16} msg] $msg -} {1 {widthInc can't be <= 0}} - -test wm-grid-1.12 {usage} { - list [catch {wm grid . 13 14 15 -1} msg] $msg -} {1 {heightInc can't be <= 0}} - -test wm-grid-2.1 {setting and reading values} { +} -result [list 150x150+50+50 0] + + +### wm grid ### +test wm-grid-1.1 {usage} -returnCodes error -body { + wm grid +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-grid-1.2 {usage} -returnCodes error -body { + wm grid . _ +} -result {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"} +test wm-grid-1.3 {usage} -returnCodes error -body { + wm grid . _ _ _ +} -result {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"} +test wm-grid-1.4 {usage} -returnCodes error -body { + wm grid . _ _ _ _ _ +} -result {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"} +test wm-grid-1.5 {usage} -returnCodes error -body { + wm grid . bad 14 15 16 +} -result {expected integer but got "bad"} +test wm-grid-1.6 {usage} -returnCodes error -body { + wm grid . 13 foo 15 16 +} -result {expected integer but got "foo"} +test wm-grid-1.7 {usage} -returnCodes error -body { + wm grid . 13 14 bar 16 +} -result {expected integer but got "bar"} +test wm-grid-1.8 {usage} -returnCodes error -body { + wm grid . 13 14 15 baz +} -result {expected integer but got "baz"} +test wm-grid-1.9 {usage} -returnCodes error -body { + wm grid . -1 14 15 16 +} -result {baseWidth can't be < 0} +test wm-grid-1.10 {usage} -returnCodes error -body { + wm grid . 13 -1 15 16 +} -result {baseHeight can't be < 0} +test wm-grid-1.11 {usage} -returnCodes error -body { + wm grid . 13 14 -1 16 +} -result {widthInc can't be <= 0} +test wm-grid-1.12 {usage} -returnCodes error -body { + wm grid . 13 14 15 -1 +} -result {heightInc can't be <= 0} + +test wm-grid-2.1 {setting and reading values} -setup { set result {} +} -body { lappend result [wm grid .t] wm grid .t 3 4 10 2 lappend result [wm grid .t] wm grid .t {} {} {} {} lappend result [wm grid .t] -} [list {} {3 4 10 2} {}] - - -test wm-group-1.1 {usage} { - list [catch {wm group} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +} -result [list {} {3 4 10 2} {}] -test wm-group-1.2 {usage} { - list [catch {wm group .t 12 13} msg] $msg -} {1 {wrong # args: should be "wm group window ?pathName?"}} -test wm-group-1.3 {usage} { - list [catch {wm group .t bogus} msg] $msg -} {1 {bad window path name "bogus"}} +### wm group ### +test wm-group-1.1 {usage} -returnCodes error -body { + wm group +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-group-1.2 {usage} -returnCodes error -body { + wm group .t 12 13 +} -result {wrong # args: should be "wm group window ?pathName?"} +test wm-group-1.3 {usage} -returnCodes error -body { + wm group .t bogus +} -result {bad window path name "bogus"} -test wm-group-2.1 {setting and reading values} { +test wm-group-2.1 {setting and reading values} -setup { set result {} +} -body { lappend result [wm group .t] wm group .t . lappend result [wm group .t] wm group .t {} lappend result [wm group .t] -} [list {} . {}] - - -test wm-iconbitmap-1.1 {usage} { - list [catch {wm iconbitmap} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-iconbitmap-1.2.1 {usage} {macOrUnix} { - list [catch {wm iconbitmap .t 12 13} msg] $msg -} {1 {wrong # args: should be "wm iconbitmap window ?bitmap?"}} - -test wm-iconbitmap-1.2.2 {usage} {pcOnly} { - list [catch {wm iconbitmap .t 12 13 14} msg] $msg -} {1 {wrong # args: should be "wm iconbitmap window ?-default? ?image?"}} - -test wm-iconbitmap-1.3 {usage} {pcOnly} { - list [catch {wm iconbitmap .t 12 13} msg] $msg -} {1 {illegal option "12" must be "-default"}} - -test wm-iconbitmap-1.4 {usage} { - list [catch {wm iconbitmap .t bad-bitmap} msg] $msg -} {1 {bitmap "bad-bitmap" not defined}} - -test wm-iconbitmap-2.1 {setting and reading values} { +} -result [list {} . {}] + + +### wm iconbitmap ### +test wm-iconbitmap-1.1 {usage} -returnCodes error -body { + wm iconbitmap +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-iconbitmap-1.2.1 {usage} -constraints unix -returnCodes error -body { + wm iconbitmap .t 12 13 +} -result {wrong # args: should be "wm iconbitmap window ?bitmap?"} +test wm-iconbitmap-1.2.2 {usage} -constraints win -returnCodes error -body { + wm iconbitmap .t 12 13 14 +} -result {wrong # args: should be "wm iconbitmap window ?-default? ?image?"} +test wm-iconbitmap-1.3 {usage} -constraints win -returnCodes error -body { + wm iconbitmap .t 12 13 +} -result {illegal option "12" must be "-default"} +test wm-iconbitmap-1.4 {usage} -returnCodes error -body { + wm iconbitmap .t bad-bitmap +} -result {bitmap "bad-bitmap" not defined} + +test wm-iconbitmap-2.1 {setting and reading values} -setup { set result {} +} -body { lappend result [wm iconbitmap .t] wm iconbitmap .t hourglass lappend result [wm iconbitmap .t] wm iconbitmap .t {} lappend result [wm iconbitmap .t] -} [list {} hourglass {}] +} -result [list {} hourglass {}] -test wm-iconify-1.1 {usage} { - list [catch {wm iconify} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +### wm iconify ### +test wm-iconify-1.1 {usage} -returnCodes error -body { + wm iconify +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-iconify-1.2 {usage} -returnCodes error -body { + wm iconify .t _ +} -result {wrong # args: should be "wm iconify window"} -test wm-iconify-1.2 {usage} { - list [catch {wm iconify .t _} msg] $msg -} {1 {wrong # args: should be "wm iconify window"}} - -test wm-iconify-2.1 {Misc errors} { - catch {destroy .t2} +destroy .t2 +test wm-iconify-2.1 {Misc errors} -body { toplevel .t2 wm overrideredirect .t2 1 - set result [list [catch {wm iconify .t2} msg] $msg] + wm iconify .t2 +} -returnCodes error -cleanup { destroy .t2 - set result -} {1 {can't iconify ".t2": override-redirect flag is set}} - -test wm-iconify-2.2 {Misc errors} { - catch {destroy .t2} +} -result {can't iconify ".t2": override-redirect flag is set} +test wm-iconify-2.2 {Misc errors} -body { toplevel .t2 wm geom .t2 +0+0 wm transient .t2 .t - set result [list [catch {wm iconify .t2} msg] $msg] + wm iconify .t2 +} -returnCodes error -cleanup { destroy .t2 - set result -} {1 {can't iconify ".t2": it is a transient}} - -test wm-iconify-2.3 {Misc errors} { - catch {destroy .t2} +} -result {can't iconify ".t2": it is a transient} +test wm-iconify-2.3 {Misc errors} -body { toplevel .t2 wm geom .t2 +0+0 wm iconwindow .t .t2 - set result [list [catch {wm iconify .t2} msg] $msg] + wm iconify .t2 +} -returnCodes error -cleanup { destroy .t2 - set result -} {1 {can't iconify .t2: it is an icon for .t}} - -test wm-iconify-2.4 {Misc errors} { - catch {destroy .t2} +} -result {can't iconify .t2: it is an icon for .t} +# test embedded window for Windows +test wm-iconify-2.4.1 {Misc errors} -constraints win -setup { + destroy .t2 +} -body { frame .t.f -container 1 toplevel .t2 -use [winfo id .t.f] - set result [list [catch {wm iconify .t2} msg] $msg] + wm iconify .t2 +} -returnCodes error -cleanup { destroy .t2 .r.f - set result -} {1 {can't iconify .t2: it is an embedded window}} +} -result {can't iconify .t2: the container does not support the request} +# test embedded window for other platforms +test wm-iconify-2.4.2 {Misc errors} -constraints !win -setup { + destroy .t2 +} -body { + frame .t.f -container 1 + toplevel .t2 -use [winfo id .t.f] + wm iconify .t2 +} -returnCodes error -cleanup { + destroy .t2 .r.f +} -result {can't iconify .t2: it is an embedded window} -test wm-iconify-3.1 {} { - catch {destroy .t2} +test wm-iconify-3.1 {iconify behavior} -body { toplevel .t2 wm geom .t2 -0+0 update @@ -528,308 +813,433 @@ test wm-iconify-3.1 {} { wm iconify .t2 update lappend result [winfo ismapped .t2] +} -cleanup { destroy .t2 - set result -} {1 0} - +} -result {1 0} -test wm-iconmask-1.1 {usage} { - list [catch {wm iconmask} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} -test wm-iconmask-1.2 {usage} { - list [catch {wm iconmask .t 12 13} msg] $msg -} {1 {wrong # args: should be "wm iconmask window ?bitmap?"}} +### wm iconmask ### +test wm-iconmask-1.1 {usage} -returnCodes error -body { + wm iconmask +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-iconmask-1.2 {usage} -returnCodes error -body { + wm iconmask .t 12 13 +} -result {wrong # args: should be "wm iconmask window ?bitmap?"} +test wm-iconmask-1.3 {usage} -returnCodes error -body { + wm iconmask .t bad-bitmap +} -result {bitmap "bad-bitmap" not defined} -test wm-iconmask-1.3 {usage} { - list [catch {wm iconmask .t bad-bitmap} msg] $msg -} {1 {bitmap "bad-bitmap" not defined}} - -test wm-iconmask-2.1 {setting and reading values} { +test wm-iconmask-2.1 {setting and reading values} -setup { set result {} +} -body { lappend result [wm iconmask .t] wm iconmask .t hourglass lappend result [wm iconmask .t] wm iconmask .t {} lappend result [wm iconmask .t] -} [list {} hourglass {}] - +} -result [list {} hourglass {}] -test wm-iconname-1.1 {usage} { - list [catch {wm iconname} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} -test wm-iconname-1.2 {usage} { - list [catch {wm iconname .t 12 13} msg] $msg -} {1 {wrong # args: should be "wm iconname window ?newName?"}} +### wm iconname ### +test wm-iconname-1.1 {usage} -returnCodes error -body { + wm iconname +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-iconname-1.2 {usage} -returnCodes error -body { + wm iconname .t 12 13 +} -result {wrong # args: should be "wm iconname window ?newName?"} -test wm-iconname-2.1 {setting and reading values} { +test wm-iconname-2.1 {setting and reading values} -setup { set result {} +} -body { lappend result [wm iconname .t] wm iconname .t ThisIconHasAName lappend result [wm iconname .t] wm iconname .t {} lappend result [wm iconname .t] -} [list {} ThisIconHasAName {}] - - -test wm-iconphoto-1.1 {usage} { - list [catch {wm iconphoto} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-iconphoto-1.2 {usage} { - list [catch {wm iconphoto .} msg] $msg -} {1 {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"}} -test wm-iconphoto-1.3 {usage} { - list [catch {wm iconphoto . notanimage} msg] $msg -} {1 {can't use "notanimage" as iconphoto: not a photo image}} -test wm-iconphoto-1.4 {usage} { +} -result [list {} ThisIconHasAName {}] + + +### wm iconphoto ### +test wm-iconphoto-1.1 {usage} -returnCodes error -body { + wm iconphoto +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-iconphoto-1.2 {usage} -returnCodes error -body { + wm iconphoto . +} -result {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"} +test wm-iconphoto-1.3 {usage} -returnCodes error -body { + wm iconphoto . notanimage +} -result {can't use "notanimage" as iconphoto: not a photo image} +test wm-iconphoto-1.4 {usage} -returnCodes error -body { # we currently have no return info - list [catch {wm iconphoto . -default} msg] $msg -} {1 {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"}} + wm iconphoto . -default +} -result {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"} # All other iconphoto tests are platform specific -test wm-iconposition-1.1 {usage} { - list [catch {wm iconposition} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-iconposition-1.2 {usage} { - list [catch {wm iconposition .t 12} msg] $msg -} {1 {wrong # args: should be "wm iconposition window ?x y?"}} - -test wm-iconposition-1.3 {usage} { - list [catch {wm iconposition .t 12 13 14} msg] $msg -} {1 {wrong # args: should be "wm iconposition window ?x y?"}} - -test wm-iconposition-1.4 {usage} { - list [catch {wm iconposition .t bad 13} msg] $msg -} {1 {expected integer but got "bad"}} -test wm-iconposition-1.5 {usage} { - list [catch {wm iconposition .t 13 lousy} msg] $msg -} {1 {expected integer but got "lousy"}} - -test wm-iconposition-2.1 {setting and reading values} { +### wm iconposition ### +test wm-iconposition-1.1 {usage} -returnCodes error -body { + wm iconposition +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-iconposition-1.2 {usage} -returnCodes error -body { + wm iconposition .t 12 +} -result {wrong # args: should be "wm iconposition window ?x y?"} +test wm-iconposition-1.3 {usage} -returnCodes error -body { + wm iconposition .t 12 13 14 +} -result {wrong # args: should be "wm iconposition window ?x y?"} +test wm-iconposition-1.4 {usage} -returnCodes error -body { + wm iconposition .t bad 13 +} -result {expected integer but got "bad"} +test wm-iconposition-1.5 {usage} -returnCodes error -body { + wm iconposition .t 13 lousy +} -result {expected integer but got "lousy"} + +test wm-iconposition-2.1 {setting and reading values} -setup { set result {} +} -body { lappend result [wm iconposition .t] wm iconposition .t 10 20 lappend result [wm iconposition .t] wm iconposition .t {} {} lappend result [wm iconposition .t] -} [list {} {10 20} {}] - - -test wm-iconwindow-1.1 {usage} { - list [catch {wm iconwindow} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-iconwindow-1.2 {usage} { - list [catch {wm iconwindow .t 12 13} msg] $msg -} {1 {wrong # args: should be "wm iconwindow window ?pathName?"}} - -test wm-iconwindow-1.3 {usage} { - list [catch {wm iconwindow .t bogus} msg] $msg -} {1 {bad window path name "bogus"}} - -test wm-iconwindow-1.4 {usage} { - catch {destroy .b} +} -result [list {} {10 20} {}] + + +### wm iconwindow ### +test wm-iconwindow-1.1 {usage} -returnCodes error -body { + wm iconwindow +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-iconwindow-1.2 {usage} -returnCodes error -body { + wm iconwindow .t 12 13 +} -result {wrong # args: should be "wm iconwindow window ?pathName?"} +test wm-iconwindow-1.3 {usage} -returnCodes error -body { + wm iconwindow .t bogus +} -result {bad window path name "bogus"} +test wm-iconwindow-1.4 {usage} -setup { + destroy .b +} -body { button .b -text Help - set result [list [catch {wm iconwindow .t .b} msg] $msg] + wm iconwindow .t .b +} -returnCodes error -cleanup { destroy .b - set result -} {1 {can't use .b as icon window: not at top level}} - -test wm-iconwindow-1.5 {usage} { - catch {destroy .icon} +} -result {can't use .b as icon window: not at top level} +test wm-iconwindow-1.5 {usage} -setup { + destroy .icon .t2 +} -body { toplevel .icon -width 50 -height 50 -bg green - catch {destroy .t2} toplevel .t2 wm geom .t2 -0+0 wm iconwindow .t2 .icon - set result [list [catch {wm iconwindow .t .icon} msg] $msg] - destroy .t2 - destroy .icon - set result -} {1 {.icon is already an icon for .t2}} + wm iconwindow .t .icon +} -returnCodes error -cleanup { + destroy .t2 .icon +} -result {.icon is already an icon for .t2} -test wm-iconwindow-2.1 {setting and reading values} { +test wm-iconwindow-2.1 {setting and reading values} -setup { + destroy .icon set result {} +} -body { lappend result [wm iconwindow .t] - catch {destroy .icon} toplevel .icon -width 50 -height 50 -bg green wm iconwindow .t .icon lappend result [wm iconwindow .t] wm iconwindow .t {} destroy .icon lappend result [wm iconwindow .t] -} [list {} .icon {}] - - -test wm-maxsize-1.1 {usage} { - list [catch {wm maxsize} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-maxsize-1.2 {usage} { - list [catch {wm maxsize . a} msg] $msg -} {1 {wrong # args: should be "wm maxsize window ?width height?"}} - -test wm-maxsize-1.3 {usage} { - list [catch {wm maxsize . a b c} msg] $msg -} {1 {wrong # args: should be "wm maxsize window ?width height?"}} - -test wm-maxsize-1.4 {usage} { - list [catch {wm maxsize . x 100} msg] $msg -} {1 {expected integer but got "x"}} - -test wm-maxsize-1.5 {usage} { - list [catch {wm maxsize . 100 bogus} msg] $msg -} {1 {expected integer but got "bogus"}} - -test wm-maxsize-1.6 {usage} { - catch {destroy .t2} +} -result {{} .icon {}} + + +### wm maxsize ### +test wm-maxsize-1.1 {usage} -returnCodes error -body { + wm maxsize +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-maxsize-1.2 {usage} -returnCodes error -body { + wm maxsize . a +} -result {wrong # args: should be "wm maxsize window ?width height?"} +test wm-maxsize-1.3 {usage} -returnCodes error -body { + wm maxsize . a b c +} -result {wrong # args: should be "wm maxsize window ?width height?"} +test wm-maxsize-1.4 {usage} -returnCodes error -body { + wm maxsize . x 100 +} -result {expected integer but got "x"} +test wm-maxsize-1.5 {usage} -returnCodes error -body { + wm maxsize . 100 bogus +} -result {expected integer but got "bogus"} +test wm-maxsize-1.6 {usage} -setup { + destroy .t2 +} -body { toplevel .t2 - wm maxsize .t2 200 150 - set result [wm maxsize .t2] + wm maxsize .t2 300 200 + wm maxsize .t2 +} -cleanup { destroy .t2 - set result -} {200 150} - - -test wm-minsize-1.1 {usage} { - list [catch {wm minsize} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-minsize-1.2 {usage} { - list [catch {wm minsize . a} msg] $msg -} {1 {wrong # args: should be "wm minsize window ?width height?"}} - -test wm-minsize-1.3 {usage} { - list [catch {wm minsize . a b c} msg] $msg -} {1 {wrong # args: should be "wm minsize window ?width height?"}} - -test wm-minsize-1.4 {usage} { - list [catch {wm minsize . x 100} msg] $msg -} {1 {expected integer but got "x"}} - -test wm-minsize-1.5 {usage} { - list [catch {wm minsize . 100 bogus} msg] $msg -} {1 {expected integer but got "bogus"}} +} -result {300 200} +test wm-maxsize-1.7 {maxsize must be <= screen size} -setup { + destroy .t +} -body { + toplevel .t + lassign [wm maxsize .t] t_width t_height + set s_width [winfo screenwidth .t] + set s_height [winfo screenheight .t] + expr {($t_width <= $s_width) && ($t_height <= $s_height)} +} -cleanup { + destroy .t +} -result 1 -test wm-minsize-1.6 {usage} { - catch {destroy .t2} +destroy .t +test wm-maxsize-2.1 {setting the maxsize to a value smaller\ + than the current size will resize a toplevel} -body { + toplevel .t -width 300 -height 300 + update + wm maxsize .t 200 150 + # UpdateGeometryInfo invoked at idle + update + lrange [split [wm geom .t] x+] 0 1 +} -cleanup { + destroy .t +} -result {200 150} +test wm-maxsize-2.2 {setting the maxsize to a value smaller\ + than the current size will resize a gridded toplevel} -body { + toplevel .t + wm grid .t 0 0 50 50 + wm geometry .t 6x6 + update + wm maxsize .t 4 3 + # UpdateGeometryInfo invoked at idle + update + lrange [split [wm geom .t] x+] 0 1 +} -cleanup { + destroy .t +} -result {4 3} +test wm-maxsize-2.3 {attempting to resize to a value\ + bigger than the current maxsize will set it to the max size} -body { + toplevel .t -width 200 -height 200 + wm maxsize .t 300 250 + update + wm geom .t 400x300 + update + lrange [split [wm geom .t] x+] 0 1 +} -cleanup { + destroy .t +} -result {300 250} +test wm-maxsize-2.4 {attempting to resize to a value bigger than the\ + current maxsize will set it to the max size when gridded} -body { + toplevel .t + wm grid .t 1 1 50 50 + wm geom .t 4x4 + wm maxsize .t 6 5 + update + wm geom .t 8x6 + update + lrange [split [wm geom .t] x+] 0 1 +} -cleanup { + destroy .t +} -result {6 5} +test wm-maxsize-2.5 {Use max size if window size is not explicitly set\ + and the reqWidth/reqHeight are bigger than the max size} -body { + toplevel .t + pack [frame .t.f -width 400 -height 400] + update idletasks + set req [list [winfo reqwidth .t] [winfo reqheight .t]] + wm maxsize .t 300 300 + update + list $req [lrange [split [wm geom .t] x+] 0 1] +} -cleanup { + destroy .t +} -result {{400 400} {300 300}} + + +### wm minsize ### +test wm-minsize-1.1 {usage} -returnCodes error -body { + wm minsize +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-minsize-1.2 {usage} -returnCodes error -body { + wm minsize . a +} -result {wrong # args: should be "wm minsize window ?width height?"} +test wm-minsize-1.3 {usage} -returnCodes error -body { + wm minsize . a b c +} -result {wrong # args: should be "wm minsize window ?width height?"} +test wm-minsize-1.4 {usage} -returnCodes error -body { + wm minsize . x 100 +} -result {expected integer but got "x"} +test wm-minsize-1.5 {usage} -returnCodes error -body { + wm minsize . 100 bogus +} -result {expected integer but got "bogus"} +test wm-minsize-1.6 {usage} -setup { + destroy .t2 +} -body { toplevel .t2 - wm minsize .t2 200 150 - set result [wm minsize .t2] + wm minsize .t2 300 200 + wm minsize .t2 +} -cleanup { destroy .t2 - set result -} {200 150} - - -test wm-overrideredirect-1.1 {usage} { - list [catch {wm overrideredirect} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +} -result {300 200} -test wm-overrideredirect-1.2 {usage} { - list [catch {wm overrideredirect .t 1 2} msg] $msg -} {1 {wrong # args: should be "wm overrideredirect window ?boolean?"}} +test wm-minsize-2.1 {setting the minsize to a value larger\ + than the current size will resize a toplevel} -body { + toplevel .t -width 200 -height 200 + update + wm minsize .t 400 300 + # UpdateGeometryInfo invoked at idle + update + lrange [split [wm geom .t] x+] 0 1 +} -cleanup { + destroy .t +} -result {400 300} +test wm-minsize-2.2 {setting the minsize to a value larger\ + than the current size will resize a gridded toplevel} -body { + toplevel .t + wm grid .t 1 1 50 50 + wm geom .t 4x4 + update + wm minsize .t 8 8 + # UpdateGeometryInfo invoked at idle + update + lrange [split [wm geom .t] x+] 0 1 +} -cleanup { + destroy .t +} -result {8 8} +test wm-minsize-2.3 {attempting to resize to a value\ + smaller than the current minsize will set it to the minsize} -body { + toplevel .t -width 400 -height 400 + wm minsize .t 300 300 + update + wm geom .t 200x200 + update + lrange [split [wm geom .t] x+] 0 1 +} -cleanup { + destroy .t +} -result {300 300} +test wm-minsize-2.4 {attempting to resize to a value smaller than the\ + current minsize will set it to the minsize when gridded} -body { + toplevel .t + wm grid .t 1 1 50 50 + wm geom .t 8x8 + wm minsize .t 6 6 + update + wm geom .t 4x4 + update + lrange [split [wm geom .t] x+] 0 1 +} -cleanup { + destroy .t +} -result {6 6} +test wm-minsize-2.5 {Use min size if window size is not explicitly set\ + and the reqWidth/reqHeight are smaller than the min size} -setup { + set result [list] +} -body { + toplevel .t + pack [frame .t.f -width 250 -height 250] + update idletasks + lappend result [list [winfo reqwidth .t] [winfo reqheight .t]] + wm minsize .t 300 300 + update + lappend result [lrange [split [wm geom .t] x+] 0 1] +} -cleanup { + destroy .t +} -result {{250 250} {300 300}} -test wm-overrideredirect-1.3 {usage} { - list [catch {wm overrideredirect .t boo} msg] $msg -} {1 {expected boolean value but got "boo"}} +stdWindow -test wm-overrideredirect-2.1 {setting and reading values} { +### wm overrideredirect ### +test wm-overrideredirect-1.1 {usage} -returnCodes error -body { + wm overrideredirect +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-overrideredirect-1.2 {usage} -returnCodes error -body { + wm overrideredirect .t 1 2 +} -result {wrong # args: should be "wm overrideredirect window ?boolean?"} +test wm-overrideredirect-1.3 {usage} -returnCodes error -body { + wm overrideredirect .t boo +} -result {expected boolean value but got "boo"} + +test wm-overrideredirect-2.1 {setting and reading values} -setup { set result {} +} -body { lappend result [wm overrideredirect .t] wm overrideredirect .t true lappend result [wm overrideredirect .t] wm overrideredirect .t off lappend result [wm overrideredirect .t] -} {0 1 0} - +} -result {0 1 0} -test wm-positionfrom-1.1 {usage} { - list [catch {wm positionfrom} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} -test wm-positionfrom-1.2 {usage} { - list [catch {wm positionfrom .t 1 2} msg] $msg -} {1 {wrong # args: should be "wm positionfrom window ?user/program?"}} +### wm positionfrom ### +test wm-positionfrom-1.1 {usage} -returnCodes error -body { + wm positionfrom +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-positionfrom-1.2 {usage} -returnCodes error -body { + wm positionfrom .t 1 2 +} -result {wrong # args: should be "wm positionfrom window ?user/program?"} +test wm-positionfrom-1.3 {usage} -returnCodes error -body { + wm positionfrom .t none +} -result {bad argument "none": must be program or user} -test wm-positionfrom-1.3 {usage} { - list [catch {wm positionfrom .t none} msg] $msg -} {1 {bad argument "none": must be program or user}} - -test wm-positionfrom-2.1 {setting and reading values} { - catch {destroy .t2} - toplevel .t2 +test wm-positionfrom-2.1 {setting and reading values} -setup { + destroy .t2 set result {} +} -body { + toplevel .t2 wm positionfrom .t user lappend result [wm positionfrom .t] wm positionfrom .t program lappend result [wm positionfrom .t] wm positionfrom .t {} lappend result [wm positionfrom .t] +} -cleanup { destroy .t2 - set result -} {user program {}} +} -result {user program {}} -test wm-protocol-1.1 {usage} { - list [catch {wm protocol} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +### wm protocol ### +test wm-protocol-1.1 {usage} -returnCodes error -body { + wm protocol +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-protocol-1.2 {usage} -returnCodes error -body { + wm protocol .t 1 2 3 +} -result {wrong # args: should be "wm protocol window ?name? ?command?"} -test wm-protocol-1.2 {usage} { - list [catch {wm protocol .t 1 2 3} msg] $msg -} {1 {wrong # args: should be "wm protocol window ?name? ?command?"}} - -test wm-protocol-2.1 {setting and reading values} { +test wm-protocol-2.1 {setting and reading values} -body { wm protocol .t {foo a} {a b c} wm protocol .t bar {test script for bar} - set result [wm protocol .t] + wm protocol .t +} -cleanup { wm protocol .t {foo a} {} wm protocol .t bar {} - set result -} {bar {foo a}} - -test wm-protocol-2.2 {setting and reading values} { +} -result {bar {foo a}} +test wm-protocol-2.2 {setting and reading values} -setup { set result {} +} -body { wm protocol .t foo {a b c} wm protocol .t bar {test script for bar} lappend result [wm protocol .t foo] [wm protocol .t bar] wm protocol .t foo {} wm protocol .t bar {} lappend result [wm protocol .t foo] [wm protocol .t bar] -} {{a b c} {test script for bar} {} {}} - -test wm-protocol-2.3 {setting and reading values} { +} -result {{a b c} {test script for bar} {} {}} +test wm-protocol-2.3 {setting and reading values} -body { wm protocol .t foo {a b c} wm protocol .t foo {test script} - set result [wm protocol .t foo] + wm protocol .t foo +} -cleanup { wm protocol .t foo {} - set result -} {test script} - - -test wm-resizable-1.1 {usage} { - list [catch {wm resizable} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-resizable-1.2 {usage} { - list [catch {wm resizable .t 1} msg] $msg -} {1 {wrong # args: should be "wm resizable window ?width height?"}} - -test wm-resizable-1.3 {usage} { - list [catch {wm resizable .t 1 2 3} msg] $msg -} {1 {wrong # args: should be "wm resizable window ?width height?"}} - -test wm-resizable-1.4 {usage} { - list [catch {wm resizable .t bad 0} msg] $msg -} {1 {expected boolean value but got "bad"}} - -test wm-resizable-1.5 {usage} { - list [catch {wm resizable .t 1 bad} msg] $msg -} {1 {expected boolean value but got "bad"}} +} -result {test script} + + +### wm resizable ### +test wm-resizable-1.1 {usage} -returnCodes error -body { + wm resizable +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-resizable-1.2 {usage} -returnCodes error -body { + wm resizable .t 1 +} -result {wrong # args: should be "wm resizable window ?width height?"} +test wm-resizable-1.3 {usage} -returnCodes error -body { + wm resizable .t 1 2 3 +} -result {wrong # args: should be "wm resizable window ?width height?"} +test wm-resizable-1.4 {usage} -returnCodes error -body { + wm resizable .t bad 0 +} -result {expected boolean value but got "bad"} +test wm-resizable-1.5 {usage} -returnCodes error -body { + wm resizable .t 1 bad +} -result {expected boolean value but got "bad"} test wm-resizable-2.1 {setting and reading values} { wm resizable .t 0 1 @@ -841,17 +1251,16 @@ test wm-resizable-2.1 {setting and reading values} { } {0 1 {1 0} {1 1}} -test wm-sizefrom-1.1 {usage} { - list [catch {wm sizefrom} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-sizefrom-1.2 {usage} { - list [catch {wm sizefrom .t 1 2} msg] $msg -} {1 {wrong # args: should be "wm sizefrom window ?user|program?"}} - -test wm-sizefrom-1.4 {usage} { - list [catch {wm sizefrom .t bad} msg] $msg -} {1 {bad argument "bad": must be program or user}} +### wm sizefrom ### +test wm-sizefrom-1.1 {usage} -returnCodes error -body { + wm sizefrom +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-sizefrom-1.2 {usage} -returnCodes error -body { + wm sizefrom .t 1 2 +} -result {wrong # args: should be "wm sizefrom window ?user|program?"} +test wm-sizefrom-1.4 {usage} -returnCodes error -body { + wm sizefrom .t bad +} -result {bad argument "bad": must be program or user} test wm-sizefrom-2.1 {setting and reading values} { set result [list [wm sizefrom .t]] @@ -863,250 +1272,236 @@ test wm-sizefrom-2.1 {setting and reading values} { lappend result [wm sizefrom .t] } {{} user program {}} - - -test wm-stackorder-1.1 {usage} { - list [catch {wm stackorder} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} - -test wm-stackorder-1.2 {usage} { - list [catch {wm stackorder . _} err] $err -} {1 {wrong # args: should be "wm stackorder window ?isabove|isbelow window?"}} - -test wm-stackorder-1.3 {usage} { - list [catch {wm stackorder . _ _ _} err] $err -} {1 {wrong # args: should be "wm stackorder window ?isabove|isbelow window?"}} - -test wm-stackorder-1.4 {usage} { - list [catch {wm stackorder . is .} err] $err -} {1 {ambiguous argument "is": must be isabove or isbelow}} - -test wm-stackorder-1.5 {usage} { - list [catch {wm stackorder _} err] $err -} {1 {bad window path name "_"}} - -test wm-stackorder-1.6 {usage} { - list [catch {wm stackorder . isabove _} err] $err -} {1 {bad window path name "_"}} - -test wm-stackorder-1.7 {usage} { - catch {destroy .t} +destroy .t + +### wm stackorder ### +test wm-stackorder-1.1 {usage} -returnCodes error -body { + wm stackorder +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-stackorder-1.2 {usage} -returnCodes error -body { + wm stackorder . _ +} -result {wrong # args: should be "wm stackorder window ?isabove|isbelow window?"} +test wm-stackorder-1.3 {usage} -returnCodes error -body { + wm stackorder . _ _ _ +} -result {wrong # args: should be "wm stackorder window ?isabove|isbelow window?"} +test wm-stackorder-1.4 {usage} -returnCodes error -body { + wm stackorder . is . +} -result {ambiguous argument "is": must be isabove or isbelow} +test wm-stackorder-1.5 {usage} -returnCodes error -body { + wm stackorder _ +} -result {bad window path name "_"} +test wm-stackorder-1.6 {usage} -returnCodes error -body { + wm stackorder . isabove _ +} -result {bad window path name "_"} +test wm-stackorder-1.7 {usage} -body { toplevel .t button .t.b - list [catch {wm stackorder .t.b} err] $err -} {1 {window ".t.b" isn't a top-level window}} - -test wm-stackorder-1.8 {usage} { - catch {destroy .t} + wm stackorder .t.b +} -cleanup { + destroy .t +} -returnCodes error -result {window ".t.b" isn't a top-level window} +test wm-stackorder-1.8 {usage} -body { toplevel .t button .t.b pack .t.b update - list [catch {wm stackorder . isabove .t.b} err] $err -} {1 {window ".t.b" isn't a top-level window}} - -test wm-stackorder-1.9 {usage} { - catch {destroy .t} + wm stackorder . isabove .t.b +} -cleanup { + destroy .t +} -returnCodes error -result {window ".t.b" isn't a top-level window} +test wm-stackorder-1.9 {usage} -body { toplevel .t button .t.b pack .t.b update - list [catch {wm stackorder . isbelow .t.b} err] $err -} {1 {window ".t.b" isn't a top-level window}} - -test wm-stackorder-1.10 {usage, isabove|isbelow toplevels must be mapped} { - catch {destroy .t} - toplevel .t ; update + wm stackorder . isbelow .t.b +} -cleanup { + destroy .t +} -returnCodes error -result {window ".t.b" isn't a top-level window} +test wm-stackorder-1.10 {usage, isabove|isbelow toplevels must be mapped} -body { + toplevel .t + update wm withdraw .t - list [catch {wm stackorder .t isabove .} err] $err -} {1 {window ".t" isn't mapped}} - -test wm-stackorder-1.11 {usage, isabove|isbelow toplevels must be mapped} { - catch {destroy .t} - toplevel .t ; update + wm stackorder .t isabove . +} -cleanup { + destroy .t +} -returnCodes error -result {window ".t" isn't mapped} +test wm-stackorder-1.11 {usage, isabove|isbelow toplevels must be mapped} -body { + toplevel .t + update wm withdraw .t - list [catch {wm stackorder . isbelow .t} err] $err -} {1 {window ".t" isn't mapped}} - - + wm stackorder . isbelow .t +} -cleanup { + destroy .t +} -returnCodes error -result {window ".t" isn't mapped} deleteWindows - -test wm-stackorder-2.1 {} { - catch {destroy .t} +test wm-stackorder-2.1 {stacking order} -body { toplevel .t ; update wm stackorder . -} {. .t} - -test wm-stackorder-2.2 {} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {. .t} +test wm-stackorder-2.2 {stacking order} -body { toplevel .t ; update raise . raiseDelay wm stackorder . -} {.t .} - -test wm-stackorder-2.3 {} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {.t .} +test wm-stackorder-2.3 {stacking order} -body { toplevel .t ; update - catch {destroy .t2} toplevel .t2 ; update raise . raise .t2 raiseDelay wm stackorder . -} {.t . .t2} - -test wm-stackorder-2.4 {} { - catch {destroy .t} +} -cleanup { + destroy .t .t2 +} -result {.t . .t2} +test wm-stackorder-2.4 {stacking order} -body { toplevel .t ; update - catch {destroy .t2} toplevel .t2 ; update raise . lower .t2 raiseDelay wm stackorder . -} {.t2 .t .} - -test wm-stackorder-2.5 {} { - catch {destroy .parent} +} -cleanup { + destroy .t .t2 +} -result {.t2 .t .} +test wm-stackorder-2.5 {stacking order} -setup { + destroy .parent +} -body { toplevel .parent ; update - catch {destroy .parent.child1} + destroy .parent.child1 toplevel .parent.child1 ; update - catch {destroy .parent.child2} + destroy .parent.child2 toplevel .parent.child2 ; update - catch {destroy .extra} + destroy .extra toplevel .extra ; update raise .parent lower .parent.child2 raiseDelay wm stackorder .parent -} {.parent.child2 .parent.child1 .parent} - -deleteWindows - -test wm-stackorder-2.6 {non-toplevel widgets ignored} { - catch {destroy .t1} +} -cleanup { + deleteWindows +} -result {.parent.child2 .parent.child1 .parent} +test wm-stackorder-2.6 {stacking order: non-toplevel widgets ignored} -body { toplevel .t1 button .t1.b pack .t1.b update wm stackorder . -} {. .t1} - -deleteWindows - -test wm-stackorder-2.7 {no children returns self} { +} -cleanup { + destroy .t1 +} -result {. .t1} +test wm-stackorder-2.7 {stacking order: no children returns self} -setup { + deleteWindows +} -body { wm stackorder . -} {.} +} -result {.} deleteWindows - -test wm-stackorder-3.1 {unmapped toplevel} { - catch {destroy .t1} +test wm-stackorder-3.1 {unmapped toplevel} -body { toplevel .t1 ; update - catch {destroy .t2} toplevel .t2 ; update wm iconify .t1 wm stackorder . -} {. .t2} - -test wm-stackorder-3.2 {unmapped toplevel} { - catch {destroy .t1} +} -cleanup { + destroy .t1 .t2 +} -result {. .t2} +test wm-stackorder-3.2 {unmapped toplevel} -body { toplevel .t1 ; update - catch {destroy .t2} toplevel .t2 ; update wm withdraw .t2 wm stackorder . -} {. .t1} - -test wm-stackorder-3.3 {unmapped toplevel} { - catch {destroy .t1} +} -cleanup { + destroy .t1 .t2 +} -result {. .t1} +test wm-stackorder-3.3 {unmapped toplevel} -body { toplevel .t1 ; update - catch {destroy .t2} toplevel .t2 ; update wm withdraw .t2 wm stackorder .t2 -} {} - -test wm-stackorder-3.4 {unmapped toplevel} { - catch {destroy .t1} +} -cleanup { + destroy .t1 .t2 +} -result {} +test wm-stackorder-3.4 {unmapped toplevel} -body { toplevel .t1 ; update toplevel .t1.t2 ; update wm withdraw .t1.t2 wm stackorder .t1 -} {.t1} - -test wm-stackorder-3.5 {unmapped toplevel} { - catch {destroy .t1} +} -cleanup { + destroy .t1 +} -result {.t1} +test wm-stackorder-3.5 {unmapped toplevel} -body { toplevel .t1 ; update toplevel .t1.t2 ; update wm withdraw .t1 wm stackorder .t1 -} {.t1.t2} - -test wm-stackorder-3.6 {unmapped toplevel} { - catch {destroy .t1} +} -cleanup { + destroy .t1 +} -result {.t1.t2} +test wm-stackorder-3.6 {unmapped toplevel} -body { toplevel .t1 ; update toplevel .t1.t2 ; update toplevel .t1.t2.t3 ; update wm withdraw .t1.t2 wm stackorder .t1 -} {.t1 .t1.t2.t3} - -test wm-stackorder-3.7 {unmapped toplevel, mapped children returned} { - catch {destroy .t1} +} -cleanup { + destroy .t1 +} -result {.t1 .t1.t2.t3} +test wm-stackorder-3.7 {unmapped toplevel, mapped children returned} -body { toplevel .t1 ; update toplevel .t1.t2 ; update wm withdraw .t1 wm stackorder .t1 -} {.t1.t2} - -test wm-stackorder-3.8 {toplevel mapped in idle callback } { - catch {destroy .t1} +} -cleanup { + destroy .t1 +} -result {.t1.t2} +test wm-stackorder-3.8 {toplevel mapped in idle callback} -body { toplevel .t1 wm stackorder . -} {.} - - +} -cleanup { + destroy .t1 +} -result {.} deleteWindows - -test wm-stackorder-4.1 {wm stackorder isabove|isbelow} { - catch {destroy .t} +test wm-stackorder-4.1 {wm stackorder isabove|isbelow} -body { toplevel .t ; update raise .t wm stackorder . isabove .t -} {0} - -test wm-stackorder-4.2 {wm stackorder isabove|isbelow} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {0} +test wm-stackorder-4.2 {wm stackorder isabove|isbelow} -body { toplevel .t ; update raise .t wm stackorder . isbelow .t -} {1} - -test wm-stackorder-4.3 {wm stackorder isabove|isbelow} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {1} +test wm-stackorder-4.3 {wm stackorder isabove|isbelow} -body { toplevel .t ; update raise . raiseDelay wm stackorder .t isa . -} {0} - -test wm-stackorder-4.4 {wm stackorder isabove|isbelow} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {0} +test wm-stackorder-4.4 {wm stackorder isabove|isbelow} -body { toplevel .t ; update raise . raiseDelay wm stackorder .t isb . -} {1} - +} -cleanup { + destroy .t +} -result {1} deleteWindows -test wm-stackorder-5.1 {a menu is not a toplevel} { - catch {destroy .t} +test wm-stackorder-5.1 {a menu is not a toplevel} -body { toplevel .t menu .t.m -type menubar .t.m add cascade -label "File" @@ -1115,117 +1510,122 @@ test wm-stackorder-5.1 {a menu is not a toplevel} { raise . raiseDelay wm stackorder . -} {.t .} - -test wm-stackorder-5.2 {A normal toplevel can't be - raised above an overrideredirect toplevel } { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {.t .} +test wm-stackorder-5.2 {A normal toplevel can't be\ + raised above an overrideredirect toplevel} -body { toplevel .t wm overrideredirect .t 1 raise . update raiseDelay wm stackorder . isabove .t -} 0 - -test wm-stackorder-5.3 {An overrideredirect window - can be explicitly lowered } { - catch {destroy .t} +} -cleanup { + destroy .t +} -result 0 +test wm-stackorder-5.3 {An overrideredirect window\ + can be explicitly lowered} -body { toplevel .t wm overrideredirect .t 1 lower .t update raiseDelay wm stackorder .t isbelow . -} 1 +} -cleanup { + destroy .t +} -result 1 -test wm-stackorder-6.1 {An embedded toplevel does not - appear in the stacking order} { - deleteWindows +test wm-stackorder-6.1 {An embedded toplevel does not\ + appear in the stacking order} -body { toplevel .real -container 1 toplevel .embd -bg blue -use [winfo id .real] update wm stackorder . -} {. .real} +} -cleanup { + deleteWindows +} -result {. .real} -stdWindow -test wm-title-1.1 {usage} { - list [catch {wm title} msg] $msg -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +stdWindow -test wm-title-1.2 {usage} { - list [catch {wm title . 1 2} msg] $msg -} {1 {wrong # args: should be "wm title window ?newTitle?"}} +### wm title ### +test wm-title-1.1 {usage} -returnCodes error -body { + wm title +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-title-1.2 {usage} -returnCodes error -body { + wm title . 1 2 +} -result {wrong # args: should be "wm title window ?newTitle?"} -test wm-title-2.1 {setting and reading values} { +test wm-title-2.1 {setting and reading values} -setup { destroy .t +} -body { toplevel .t set result [wm title .t] wm title .t Apa lappend result [wm title .t] wm title .t {} lappend result [wm title .t] -} {t Apa {}} +} -result {t Apa {}} -test wm-transient-1.1 {usage} { +### wm transient ### +test wm-transient-1.1 {usage} -returnCodes error -body { catch {destroy .t} ; toplevel .t - list [catch {wm transient .t 1 2} msg] $msg -} {1 {wrong # args: should be "wm transient window ?master?"}} - -test wm-transient-1.2 {usage} { + wm transient .t 1 2 +} -result {wrong # args: should be "wm transient window ?master?"} +test wm-transient-1.2 {usage} -returnCodes error -body { catch {destroy .t} ; toplevel .t - list [catch {wm transient .t foo} msg] $msg -} {1 {bad window path name "foo"}} - -test wm-transient-1.3 {usage} { + wm transient .t foo +} -result {bad window path name "foo"} +test wm-transient-1.3 {usage} -returnCodes error -body { catch {destroy .t} ; toplevel .t - list [catch {wm transient foo .t} msg] $msg -} {1 {bad window path name "foo"}} - -test wm-transient-1.4 {usage} { - deleteWindows + wm transient foo .t +} -result {bad window path name "foo"} +deleteWindows +test wm-transient-1.4 {usage} -returnCodes error -body { toplevel .master toplevel .subject wm transient .subject .master - list [catch {wm iconify .subject} msg] $msg -} {1 {can't iconify ".subject": it is a transient}} - -test wm-transient-1.5 {usage} { + wm iconify .subject +} -cleanup { deleteWindows +} -result {can't iconify ".subject": it is a transient} +test wm-transient-1.5 {usage} -returnCodes error -body { toplevel .icon -bg blue toplevel .top wm iconwindow .top .icon toplevel .dummy - list [catch {wm transient .icon .dummy} msg] $msg -} {1 {can't make ".icon" a transient: it is an icon for .top}} - -test wm-transient-1.6 {usage} { + wm transient .icon .dummy +} -cleanup { deleteWindows +} -result {can't make ".icon" a transient: it is an icon for .top} +test wm-transient-1.6 {usage} -returnCodes error -body { toplevel .icon -bg blue toplevel .top wm iconwindow .top .icon toplevel .dummy - list [catch {wm transient .dummy .icon} msg] $msg -} {1 {can't make ".icon" a master: it is an icon for .top}} - -test wm-transient-1.7 {usage} { + wm transient .dummy .icon +} -cleanup { deleteWindows +} -result {can't make ".icon" a master: it is an icon for .top} +test wm-transient-1.7 {usage} -returnCodes error -body { toplevel .master - list [catch {wm transient .master .master} err] $err -} {1 {can't make ".master" its own master}} - -test wm-transient-1.8 {usage} { + wm transient .master .master +} -cleanup { deleteWindows +} -result {can't make ".master" its own master} +test wm-transient-1.8 {usage} -returnCodes error -body { toplevel .master frame .master.f - list [catch {wm transient .master .master.f} err] $err -} {1 {can't make ".master" its own master}} - -test wm-transient-2.1 { basic get/set of master } { + wm transient .master .master.f +} -cleanup { deleteWindows - set results [list] +} -result {can't make ".master" its own master} + +test wm-transient-2.1 {basic get/set of master} -setup { + set results [list] +} -body { toplevel .master toplevel .subject lappend results [wm transient .subject] @@ -1233,22 +1633,21 @@ test wm-transient-2.1 { basic get/set of master } { lappend results [wm transient .subject] wm transient .subject {} lappend results [wm transient .subject] - set results -} {{} .master {}} - -test wm-transient-2.2 { first toplevel parent of - non-toplevel master is used } { +} -cleanup { deleteWindows +} -result {{} .master {}} +test wm-transient-2.2 {first toplevel parent of non-toplevel master is used} -body { toplevel .master frame .master.f toplevel .subject wm transient .subject .master.f wm transient .subject -} {.master} - -test wm-transient-3.1 { transient toplevel is withdrawn - when mapped if master is withdrawn } { +} -cleanup { deleteWindows +} -result {.master} + +test wm-transient-3.1 {transient toplevel is withdrawn + when mapped if master is withdrawn} -body { toplevel .master wm withdraw .master update @@ -1256,11 +1655,11 @@ test wm-transient-3.1 { transient toplevel is withdrawn wm transient .subject .master update list [wm state .subject] [winfo ismapped .subject] -} {withdrawn 0} - -test wm-transient-3.2 { already mapped transient toplevel - takes on withdrawn state of master } { +} -cleanup { deleteWindows +} -result {withdrawn 0} +test wm-transient-3.2 {already mapped transient toplevel + takes on withdrawn state of master} -body { toplevel .master wm withdraw .master update @@ -1269,30 +1668,29 @@ test wm-transient-3.2 { already mapped transient toplevel wm transient .subject .master update list [wm state .subject] [winfo ismapped .subject] -} {withdrawn 0} - -test wm-transient-3.3 { withdraw/deiconify on the master - also does a withdraw/deiconify on the transient } { +} -cleanup { deleteWindows +} -result {withdrawn 0} +test wm-transient-3.3 {withdraw/deiconify on the master + also does a withdraw/deiconify on the transient} -setup { set results [list] +} -body { toplevel .master toplevel .subject update wm transient .subject .master wm withdraw .master update - lappend results [wm state .subject] \ - [winfo ismapped .subject] + lappend results [wm state .subject] [winfo ismapped .subject] wm deiconify .master update - lappend results [wm state .subject] \ - [winfo ismapped .subject] - set results -} {withdrawn 0 normal 1} - -test wm-transient-4.1 { transient toplevel is withdrawn - when mapped if master is iconic } { + lappend results [wm state .subject] [winfo ismapped .subject] +} -cleanup { deleteWindows +} -result {withdrawn 0 normal 1} + +test wm-transient-4.1 {transient toplevel is withdrawn + when mapped if master is iconic} -body { toplevel .master wm iconify .master update @@ -1300,11 +1698,11 @@ test wm-transient-4.1 { transient toplevel is withdrawn wm transient .subject .master update list [wm state .subject] [winfo ismapped .subject] -} {withdrawn 0} - -test wm-transient-4.2 { already mapped transient toplevel - is withdrawn if master is iconic } { +} -cleanup { deleteWindows +} -result {withdrawn 0} +test wm-transient-4.2 {already mapped transient toplevel + is withdrawn if master is iconic} -body { toplevel .master wm iconify .master update @@ -1313,31 +1711,31 @@ test wm-transient-4.2 { already mapped transient toplevel wm transient .subject .master update list [wm state .subject] [winfo ismapped .subject] -} {withdrawn 0} - -test wm-transient-4.3 { iconify/deiconify on the master - does a withdraw/deiconify on the transient } { +} -cleanup { deleteWindows +} -result {withdrawn 0} +test wm-transient-4.3 {iconify/deiconify on the master + does a withdraw/deiconify on the transient} -setup { set results [list] +} -body { toplevel .master toplevel .subject update wm transient .subject .master wm iconify .master update - lappend results [wm state .subject] \ - [winfo ismapped .subject] + lappend results [wm state .subject] [winfo ismapped .subject] wm deiconify .master update - lappend results [wm state .subject] \ - [winfo ismapped .subject] - set results -} {withdrawn 0 normal 1} - -test wm-transient-5.1 { an error during transient command should not - cause the map/unmap binding to be deleted } { + lappend results [wm state .subject] [winfo ismapped .subject] +} -cleanup { deleteWindows +} -result {withdrawn 0 normal 1} + +test wm-transient-5.1 {an error during transient command should not + cause the map/unmap binding to be deleted} -setup { set results [list] +} -body { toplevel .master toplevel .subject update @@ -1350,12 +1748,11 @@ test wm-transient-5.1 { an error during transient command should not wm deiconify .master update lappend results [wm state .subject] - set results -} {1 withdrawn normal} - -test wm-transient-5.2 { remove transient property when master - is destroyed } { +} -cleanup { deleteWindows +} -result {1 withdrawn normal} +test wm-transient-5.2 {remove transient property when master + is destroyed} -body { toplevel .master toplevel .subject wm transient .subject .master @@ -1363,21 +1760,22 @@ test wm-transient-5.2 { remove transient property when master destroy .master update wm transient .subject -} {} - -test wm-transient-5.3 { remove transient property from window - that had never been mapped when master is destroyed } { +} -cleanup { deleteWindows +} -result {} +test wm-transient-5.3 {remove transient property from window + that had never been mapped when master is destroyed} -body { toplevel .master toplevel .subject wm transient .subject .master destroy .master wm transient .subject -} {} - -test wm-transient-6.1 { a withdrawn transient does not track - state changes in the master } { +} -cleanup { deleteWindows +} -result {} + +test wm-transient-6.1 {a withdrawn transient does not track + state changes in the master} -body { toplevel .master toplevel .subject update @@ -1388,12 +1786,13 @@ test wm-transient-6.1 { a withdrawn transient does not track # idle handler should not map the transient update wm state .subject -} {withdrawn} - -test wm-transient-6.2 { a withdrawn transient does not track - state changes in the master } { - set results [list] +} -cleanup { deleteWindows +} -result {withdrawn} +test wm-transient-6.2 {a withdrawn transient does not track + state changes in the master} -setup { + set results [list] +} -body { toplevel .master toplevel .subject update @@ -1412,11 +1811,11 @@ test wm-transient-6.2 { a withdrawn transient does not track # idle handler should map transient update lappend results [wm state .subject] -} {withdrawn normal withdrawn normal} - -test wm-transient-6.3 { a withdrawn transient does not track - state changes in the master } { +} -cleanup { deleteWindows +} -result {withdrawn normal withdrawn normal} +test wm-transient-6.3 {a withdrawn transient does not track + state changes in the master} -body { toplevel .master toplevel .subject update @@ -1428,265 +1827,467 @@ test wm-transient-6.3 { a withdrawn transient does not track # idle handler should not map the transient update wm state .subject -} {withdrawn} +} -cleanup { + deleteWindows +} -result {withdrawn} # wm-transient-7.*: See SF Tk Bug #592201 "wm transient fails with two masters" # wm-transient-7.3 through 7.5 all caused panics on Unix in Tk 8.4b1. # 7.1 and 7.2 added to catch (potential) future errors. # -test wm-transient-7.1 {Destroying transient} { - deleteWindows - toplevel .t - toplevel .transient +test wm-transient-7.1 {Destroying transient} -body { + toplevel .t + toplevel .transient wm transient .transient .t destroy .transient destroy .t # OK: the above did not cause a panic. -} {} - -test wm-transient-7.2 {Destroying master} { +} -cleanup { deleteWindows +} +test wm-transient-7.2 {Destroying master} -body { toplevel .t - toplevel .transient + toplevel .transient wm transient .transient .t destroy .t - set result [wm transient .transient] - destroy .transient - set result -} {} - -test wm-transient-7.3 {Reassign transient, destroy old master} { + wm transient .transient +} -cleanup { deleteWindows - toplevel .t1 - toplevel .t2 +} -result {} +test wm-transient-7.3 {Reassign transient, destroy old master} -body { + toplevel .t1 + toplevel .t2 toplevel .transient wm transient .transient .t1 wm transient .transient .t2 destroy .t1 ;# Caused panic in 8.4b1 - destroy .t2 + destroy .t2 destroy .transient -} {} - -test wm-transient-7.4 {Reassign transient, destroy new master} { +} -cleanup { deleteWindows - toplevel .t1 - toplevel .t2 +} +test wm-transient-7.4 {Reassign transient, destroy new master} -body { + toplevel .t1 + toplevel .t2 toplevel .transient wm transient .transient .t1 wm transient .transient .t2 destroy .t2 ;# caused panic in 8.4b1 destroy .t1 destroy .transient -} {} - -test wm-transient-7.5 {Reassign transient, destroy transient} { +} -cleanup { deleteWindows - toplevel .t1 - toplevel .t2 +} +test wm-transient-7.5 {Reassign transient, destroy transient} -body { + toplevel .t1 + toplevel .t2 toplevel .transient wm transient .transient .t1 wm transient .transient .t2 destroy .transient destroy .t2 ;# caused panic in 8.4b1 destroy .t1 ;# so did this -} {} +} -cleanup { + deleteWindows +} -test wm-state-1.1 {usage} { - list [catch {wm state} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} +test wm-transient-8.1 {transient to withdrawn window, Bug 1163496} -setup { + deleteWindows + set result {} +} -body { + # Verifies that transients stay on top of their masters, even if they were + # made transients when those masters were withdrawn. + toplevel .t1; wm withdraw .t1; update + toplevel .t2; wm transient .t2 .t1; update + lappend result [winfo ismapped .t1] [winfo ismapped .t2] + wm deiconify .t1; update + lappend result [winfo ismapped .t1] [winfo ismapped .t2] + raise .t1; update + lappend result [lsearch -all -inline -glob [wm stackorder .] ".t?"] +} -cleanup { + deleteWindows +} -result {0 0 1 1 {.t1 .t2}} -test wm-state-1.2 {usage} { - list [catch {wm state . _ _} err] $err -} {1 {wrong # args: should be "wm state window ?state?"}} -test wm-state-2.1 {initial state} { - deleteWindows +### wm state ### +test wm-state-1.1 {usage} -returnCodes error -body { + wm state +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-state-1.2 {usage} -returnCodes error -body { + wm state . _ _ +} -result {wrong # args: should be "wm state window ?state?"} + +deleteWindows +test wm-state-2.1 {initial state} -body { toplevel .t wm state .t -} {normal} - -test wm-state-2.2 {state change before map} { +} -cleanup { deleteWindows +} -result {normal} +test wm-state-2.2 {state change before map} -body { toplevel .t wm state .t withdrawn wm state .t -} {withdrawn} - -test wm-state-2.3 {state change before map} { +} -cleanup { deleteWindows +} -result {withdrawn} +test wm-state-2.3 {state change before map} -body { toplevel .t wm withdraw .t wm state .t -} {withdrawn} - -test wm-state-2.4 {state change after map} { +} -cleanup { deleteWindows +} -result {withdrawn} +test wm-state-2.4 {state change after map} -body { toplevel .t update wm state .t withdrawn wm state .t -} {withdrawn} - -test wm-state-2.5 {state change after map} { +} -cleanup { deleteWindows +} -result {withdrawn} +test wm-state-2.5 {state change after map} -body { toplevel .t update wm withdraw .t wm state .t -} {withdrawn} - -test wm-state-2.6 {state change before map} { +} -cleanup { deleteWindows +} -result {withdrawn} +test wm-state-2.6 {state change before map} -body { toplevel .t wm state .t iconic wm state .t -} {iconic} - -test wm-state-2.7 {state change before map} { +} -cleanup { deleteWindows +} -result {iconic} +test wm-state-2.7 {state change before map} -body { toplevel .t wm iconify .t wm state .t -} {iconic} - -test wm-state-2.8 {state change after map} { +} -cleanup { deleteWindows +} -result {iconic} +test wm-state-2.8 {state change after map} -body { toplevel .t update wm state .t iconic wm state .t -} {iconic} - -test wm-state-2.9 {state change after map} { +} -cleanup { deleteWindows +} -result {iconic} +test wm-state-2.9 {state change after map} -body { toplevel .t update wm iconify .t wm state .t -} {iconic} - -test wm-state-2.10 {state change before map} { +} -cleanup { deleteWindows +} -result {iconic} +test wm-state-2.10 {state change before map} -body { toplevel .t wm withdraw .t wm state .t normal wm state .t -} {normal} - -test wm-state-2.11 {state change before map} { +} -cleanup { deleteWindows +} -result {normal} +test wm-state-2.11 {state change before map} -body { toplevel .t wm withdraw .t wm deiconify .t wm state .t -} {normal} - -test wm-state-2.12 {state change after map} { +} -cleanup { deleteWindows +} -result {normal} +test wm-state-2.12 {state change after map} -body { toplevel .t update wm withdraw .t wm state .t normal wm state .t -} {normal} - -test wm-state-2.13 {state change after map} { +} -cleanup { deleteWindows +} -result {normal} +test wm-state-2.13 {state change after map} -body { toplevel .t update wm withdraw .t wm deiconify .t wm state .t -} {normal} - -test wm-state-2.14 {state change before map} { +} -cleanup { deleteWindows +} -result {normal} +test wm-state-2.14 {state change before map} -body { toplevel .t wm iconify .t wm state .t normal wm state .t -} {normal} - -test wm-state-2.15 {state change before map} { +} -cleanup { deleteWindows +} -result {normal} +test wm-state-2.15 {state change before map} -body { toplevel .t wm iconify .t wm deiconify .t wm state .t -} {normal} - -test wm-state-2.16 {state change after map} { +} -cleanup { deleteWindows +} -result {normal} +test wm-state-2.16 {state change after map} -body { toplevel .t update wm iconify .t wm state .t normal wm state .t -} {normal} - -test wm-state-2.17 {state change after map} { +} -cleanup { deleteWindows +} -result {normal} +test wm-state-2.17 {state change after map} -body { toplevel .t update wm iconify .t wm deiconify .t wm state .t -} {normal} - -test wm-state-2.18 {state change after map} {pcOnly} { +} -cleanup { deleteWindows +} -result {normal} +test wm-state-2.18 {state change after map} -constraints win -body { toplevel .t update wm state .t zoomed wm state .t -} {zoomed} +} -cleanup { + deleteWindows +} -result {zoomed} -test wm-withdraw-1.1 {usage} { - list [catch {wm withdraw} err] $err -} {1 {wrong # args: should be "wm option window ?arg ...?"}} -test wm-withdraw-1.2 {usage} { - list [catch {wm withdraw . _} msg] $msg -} {1 {wrong # args: should be "wm withdraw window"}} +### wm withdraw ### +test wm-withdraw-1.1 {usage} -returnCodes error -body { + wm withdraw +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-withdraw-1.2 {usage} -returnCodes error -body { + wm withdraw . _ +} -result {wrong # args: should be "wm withdraw window"} -test wm-withdraw-2.1 {Misc errors} { - deleteWindows +deleteWindows +test wm-withdraw-2.1 {Misc errors} -body { toplevel .t toplevel .t2 wm iconwindow .t .t2 - set result [list [catch {wm withdraw .t2} msg] $msg] - destroy .t2 - set result -} {1 {can't withdraw .t2: it is an icon for .t}} + wm withdraw .t2 +} -returnCodes error -cleanup { + deleteWindows +} -result {can't withdraw .t2: it is an icon for .t} -test wm-withdraw-3.1 {} { - update +test wm-withdraw-3.1 {} -setup { set result {} +} -body { + toplevel .t + update wm withdraw .t lappend result [wm state .t] [winfo ismapped .t] wm deiconify .t lappend result [wm state .t] [winfo ismapped .t] -} {withdrawn 0 normal 1} +} -cleanup { + deleteWindows +} -result {withdrawn 0 normal 1} + -test wm-deletion-epoch-1.1 {Deletion epoch on multiple displays} {altDisplay} { +### Misc. wm tests ### +test wm-deletion-epoch-1.1 {Deletion epoch on multiple displays} -constraints altDisplay -body { # See Tk Bug #671330 "segfault when e.g. deiconifying destroyed window" - deleteWindows set w [toplevel .t -screen $env(TK_ALT_DISPLAY)] wm deiconify $w ;# this caches the WindowRep destroy .t - list [catch {wm deiconify $w} msg] $msg -} {1 {bad window path name ".t"}} + wm deiconify $w +} -returnCodes error -result {bad window path name ".t"} -cleanup { + deleteWindows +} + +### Docking test (manage, forget) ### +test wm-manage-1.1 {managing a frame} -setup { + set result [list] +} -body { + toplevel .t + frame .t.f + pack [label .t.f.l -text hello] + wm manage .t.f + raise .t.f + update + lappend result [winfo manage .t.f] + lappend result [winfo toplevel .t.f] +} -cleanup { + deleteWindows +} -result {wm .t.f} +test wm-manage-1.2 {managing a toplevel} -setup { + set result [list] +} -body { + toplevel .t + pack [label .t.l -text hello] + wm manage .t + raise .t + update + lappend result [winfo manage .t] + lappend result [winfo toplevel .t] +} -cleanup { + deleteWindows +} -result {wm .t} +test wm-manage-1.3 {managing a labelframe} -setup { + set result [list] +} -body { + toplevel .t + labelframe .t.f -text Labelframe + pack [label .t.f.l -text hello] + wm manage .t.f + raise .t.f + update + lappend result [winfo manage .t.f] + lappend result [winfo toplevel .t.f] +} -cleanup { + deleteWindows +} -result {wm .t.f} +test wm-manage-1.4 {managing a ttk::frame} -setup { + set result [list] +} -body { + toplevel .t + ttk::frame .t.f + pack [label .t.f.l -text hello] + wm manage .t.f + raise .t.f + update + lappend result [winfo manage .t.f] + lappend result [winfo toplevel .t.f] +} -cleanup { + deleteWindows +} -returnCodes error -result "window \".t.f\" is not manageable: must be a frame, labelframe or toplevel" +test wm-manage-1.5 {managing a text widget} -setup { + set result [list] +} -body { + toplevel .t + text .t.f + .t.f insert end "Manage text\n" {} + wm manage .t.f + raise .t.f + update + lappend result [winfo manage .t.f] + lappend result [winfo toplevel .t.f] +} -cleanup { + deleteWindows +} -returnCodes error -result "window \".t.f\" is not manageable: must be a frame, labelframe or toplevel" +test wm-manage-1.6 {managing a button} -setup { + set result [list] +} -body { + toplevel .t + button .t.f -text Button + wm manage .t.f + raise .t.f + update + lappend result [winfo manage .t.f] + lappend result [winfo toplevel .t.f] +} -cleanup { + deleteWindows +} -returnCodes error -result "window \".t.f\" is not manageable: must be a frame, labelframe or toplevel" +test wm-manage-1.7 {managing a frame} -setup { + set result [list] +} -body { + toplevel .t + frame .t.f + pack [label .t.f.l -text Label] + pack .t.f + update + lappend result [winfo manage .t.f] + lappend result [winfo toplevel .t.f] + wm manage .t.f + raise .t.f + update + lappend result [winfo manage .t.f] + lappend result [winfo toplevel .t.f] + wm forget .t.f + pack .t.f + update + lappend result [winfo manage .t.f] + lappend result [winfo toplevel .t.f] +} -cleanup { + deleteWindows +} -result {pack .t wm .t.f pack .t} +test wm-manage-1.8 {unmanaging a toplevel} -setup { + set result [list] +} -body { + toplevel .t + toplevel .t.t + button .t.t.b -text "Manage This" + pack .t.t.b + update + lappend result [winfo manage .t.t] + lappend result [winfo toplevel .t.t.b] + wm forget .t.t + wm forget .t.t ; # second call should be a no-op + pack .t.t + update + lappend result [winfo manage .t.t] + lappend result [winfo toplevel .t.t.b] + wm manage .t.t + wm manage .t.t ; # second call should be a no-op + wm deiconify .t.t + update + lappend result [winfo manage .t.t] + lappend result [winfo toplevel .t.t.b] +} -cleanup { + deleteWindows +} -result {wm .t.t pack .t wm .t.t} + +test wm-forget-1.1 "bug #2009788: forget toplevel can cause crash" -body { + toplevel .parent + toplevel .parent.child + wm forget .parent.child + winfo exists .parent.child +} -cleanup { + deleteWindows +} -result {1} +test wm-forget-1.2 "bug #2009788: forget toplevel can cause crash" -body { + toplevel .parent + update + toplevel .parent.child + wm forget .parent.child + winfo exists .parent.child +} -cleanup { + deleteWindows +} -result {1} +test wm-forget-1.3 "bug #2009788: forget toplevel can cause crash" -body { + toplevel .parent + toplevel .parent.child + wm forget .parent.child + wm manage .parent.child + winfo exists .parent.child +} -cleanup { + deleteWindows +} -result {1} +test wm-forget-1.4 "pack into unmapped toplevel causes crash" -body { + toplevel .parent + toplevel .parent.child + wm forget .parent.child + pack [button .parent.child.button -text Hello] + after 250 {destroy .parent} + tkwait window .parent +} -cleanup { + deleteWindows +} -result {} # FIXME: -# Test delivery of virtual events to the WM. We could check to see -# if the window was raised after a button click for example. -# This sort of testing may not be possible. +# Test delivery of virtual events to the WM. We could check to see if the +# window was raised after a button click for example. This sort of testing may +# not be possible. +############################################################################## deleteWindows -tcltest::cleanupTests +cleanupTests +catch {unset results} +catch {unset focusin} return - - +# Local variables: +# mode: tcl +# End: diff --git a/tests/xmfbox.test b/tests/xmfbox.test index 43f981c..b60bf48 100644 --- a/tests/xmfbox.test +++ b/tests/xmfbox.test @@ -11,10 +11,7 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands set testPWD [pwd] @@ -60,14 +57,14 @@ proc cleanup {} { catch {destroy .foo} } -test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} {unixOnly} { +test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} unix { catch {unset foo} set x [tk::MotifFDialog_Create foo open {-parent .}] catch {destroy $x} set x } .foo -test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} {unixOnly} { +test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} unix { catch {unset foo} toplevel .bar wm geometry .bar +0+0 @@ -77,7 +74,7 @@ test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} {unixOnly} { set x } .bar.foo -test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} {unixOnly} { +test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} unix { cleanup file mkdir ./~nosuchuser1 set x [tk::MotifFDialog_Create foo open {}] @@ -86,7 +83,7 @@ test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} {unixOnly} { set kk [tk::MotifFDialog_InterpFilter $x] } [list $testPWD/~nosuchuser1 *] -test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} {unixOnly} { +test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} unix { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -95,7 +92,7 @@ test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} {unixOnly} { set kk [tk::MotifFDialog_InterpFilter $x] } [list $testPWD ./~nosuchuser1] -test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} {unixOnly} { +test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} unix { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -106,7 +103,7 @@ test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} {unixOnly} { $::tk::dialog::file::foo(fList) get end } ~nosuchuser1 -test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} {unixOnly} { +test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} unix { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -114,7 +111,7 @@ test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} {unixOnly} { expr {$i >= 0} } 1 -test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} {unixOnly} { +test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} unix { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -125,7 +122,7 @@ test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} {unixOnly} { $::tk::dialog::file::foo(sEnt) get } $testPWD/~nosuchuser1 -test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} {unixOnly} { +test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} unix { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -140,17 +137,5 @@ test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} {unixOnly} { # cleanup cleanup -::tcltest::cleanupTests +cleanupTests return - - - - - - - - - - - - |
