diff options
Diffstat (limited to 'tests')
86 files changed, 41672 insertions, 0 deletions
diff --git a/tests/README b/tests/README new file mode 100644 index 0000000..2ae2a44 --- /dev/null +++ b/tests/README @@ -0,0 +1,30 @@ +Tk Test Suite +-------------- + +SCCS: @(#) README 1.2 96/03/27 08:52:21 + +This directory contains a set of validation tests for Tk. +Each of the files whose name ends in ".test" is intended to +fully exercise one or a few Tk features. The features +tested by a given file are listed in the first line of the +file. The test suite is nowhere near complete yet. Contributions +of additional tests would be most welcome. + +You can run the tests in two ways: + (a) type "make test" in the directory ../unix; this will run all of + the tests. + (b) start up tktest in this directory, then "source" the test + file (for example, type "source pack.test"). To run all + of the tests, type "source all". +In either case no output will be generated if all goes well, except +for a listing of the tests. If there are errors then additional +messages will appear. + +For more details on the testing environment, see the README +file in the Tcl test directory. + +You can also run a set of visual tests, which create various screens +that you can verify visually for appropriate behavior. The visual +tests are available through the "visual" script: if you invoke this +script, it creates a main window with a bunch of menus. Each menu +runs a particular test. diff --git a/tests/all b/tests/all new file mode 100644 index 0000000..38d2ca0 --- /dev/null +++ b/tests/all @@ -0,0 +1,57 @@ +# This file contains a top-level script to run all of the Tcl +# tests. Execute it by invoking "source all" when running tclTest +# in this directory. +# +# SCCS: @(#) all 1.23 97/08/06 18:50:18 + +switch $tcl_platform(platform) { + "windows" { + # Tests that cause tk to crash under windows. + set crash {} + + # Tests that fail under windows. + + set fail { grid.test } + + if {! [info exist exclude] } { + set exclude [string tolower "$crash $fail"] + } + } + "macintosh" { + set x [pwd] + cd $tk_library + set tk_library [pwd] + cd $x + + # Tests that cause tk to crash under mac. + set crash {} + + # Tests that fail under mac. + set fail {bind.test entry.test send.test textDisp.test} + + set exclude [string tolower "$crash $fail"] + } + "unix" { + set exclude "" + } +} + +if {$tcl_platform(os) == "Win32s"} { + set tests [lsort [glob *.tes]] +} else { + set tests [lsort [glob *.test]] +} + +foreach i $tests { + if [string match l.*.test $i] { + # This is an SCCS lock file; ignore it. + continue + } + if [lsearch $exclude [string tolower $i]]>=0 { + # Do not source this file; it exercises a known bug at this time. + puts stdout "Skipping $i" + continue + } + puts stdout $i + source $i +} diff --git a/tests/arc.tcl b/tests/arc.tcl new file mode 100644 index 0000000..62ea96d --- /dev/null +++ b/tests/arc.tcl @@ -0,0 +1,140 @@ +# This file creates a visual test for arcs. It is part of the Tk +# visual test suite, which is invoked via the "visual" script. +# +# SCCS: @(#) arc.tcl 1.5 96/02/16 10:55:40 + +catch {destroy .t} +toplevel .t +wm title .t "Visual Tests for Canvas Arcs" +wm iconname .t "Arcs" +wm geom .t +0+0 +wm minsize .t 1 1 + +canvas .t.c -width 650 -height 600 -relief raised +pack .t.c -expand yes -fill both +button .t.quit -text Quit -command {destroy .t} +pack .t.quit -side bottom -pady 3 -ipadx 4 -ipady 2 + +puts "depth is [winfo depth .t]" +if {[winfo depth .t] > 1} { + set fill1 aquamarine3 + set fill2 aquamarine3 + set fill3 IndianRed1 + set outline2 IndianRed3 +} else { + set fill1 black + set fill2 white + set fill3 Black + set outline2 white +} +set outline black + +.t.c create arc 20 20 220 120 -start 30 -extent 270 -outline $fill1 -width 14 \ + -style arc +.t.c create arc 260 20 460 120 -start 30 -extent 270 -fill $fill2 -width 14 \ + -style chord -outline $outline +.t.c create arc 500 20 620 160 -start 30 -extent 270 -fill {} -width 14 \ + -style chord -outline $outline -outlinestipple gray50 +.t.c create arc 20 260 140 460 -start 45 -extent 90 -fill $fill2 -width 14 \ + -style pieslice -outline $outline +.t.c create arc 180 260 300 460 -start 45 -extent 90 -fill {} -width 14 \ + -style pieslice -outline $outline +.t.c create arc 340 260 460 460 -start 30 -extent 150 -fill $fill2 -width 14 \ + -style chord -outline $outline -stipple gray50 -outlinestipple gray25 +.t.c create arc 500 260 620 460 -start 30 -extent 150 -fill {} -width 14 \ + -style chord -outline $outline +.t.c create arc 20 450 140 570 -start 135 -extent 270 -fill $fill1 -width 14 \ + -style pieslice -outline {} +.t.c create arc 180 450 300 570 -start 30 -extent -90 -fill $fill1 -width 14 \ + -style pieslice -outline {} +.t.c create arc 340 450 460 570 -start 320 -extent 270 -fill $fill1 -width 14 \ + -style chord -outline {} +.t.c create arc 500 450 620 570 -start 350 -extent -110 -fill $fill1 -width 14 \ + -style chord -outline {} +.t.c addtag arc withtag all +.t.c addtag circle withtag [.t.c create oval 320 200 340 220 -fill MistyRose3] + +.t.c bind arc <Any-Enter> { + set prevFill [lindex [.t.c itemconf current -fill] 4] + set prevOutline [lindex [.t.c itemconf current -outline] 4] + if {($prevFill != "") || ($prevOutline == "")} { + .t.c itemconf current -fill $fill3 + } + if {$prevOutline != ""} { + .t.c itemconf current -outline $outline2 + } +} +.t.c bind arc <Any-Leave> {.t.c itemconf current -fill $prevFill -outline $prevOutline} + +bind .t.c <1> {markarea %x %y} +bind .t.c <B1-Motion> {strokearea %x %y} + +proc markarea {x y} { + global areaX1 areaY1 + set areaX1 $x + set areaY1 $y +} + +proc strokearea {x y} { + global areaX1 areaY1 areaX2 areaY2 + if {($areaX1 != $x) && ($areaY1 != $y)} { + .t.c delete area + .t.c addtag area withtag [.t.c create rect $areaX1 $areaY1 $x $y \ + -outline black] + set areaX2 $x + set areaY2 $y + } +} + +bind .t.c <Control-f> { + puts stdout "Enclosed: [.t.c find enclosed $areaX1 $areaY1 $areaX2 $areaY2]" + puts stdout "Overlapping: [.t.c find overl $areaX1 $areaY1 $areaX2 $areaY2]" +} + +bind .t.c <3> {puts stdout "%x %y"} + +# The code below allows the circle to be move by shift-dragging. + +bind .t.c <Shift-1> { + set curx %x + set cury %y +} + +bind .t.c <Shift-B1-Motion> { + .t.c move circle [expr %x-$curx] [expr %y-$cury] + set curx %x + set cury %y +} + +# The binding below flashes the closest item to the mouse. + +bind .t.c <Control-c> { + set closest [.t.c find closest %x %y] + set oldfill [lindex [.t.c itemconf $closest -fill] 4] + .t.c itemconf $closest -fill IndianRed1 + after 200 [list .t.c itemconfig $closest -fill $oldfill] +} + +proc c {option value} {.t.c itemconf 2 $option $value} + +bind .t.c a { + set go 1 + set i 1 + while {$go} { + if {$i >= 50} { + set delta -5 + } + if {$i <= 5} { + set delta 5 + } + incr i $delta + c -start $i + c -extent [expr 360-2*$i] + after 20 + update + } +} + +bind .t.c b {set go 0} + +bind .t.c <Control-x> {.t.c delete current} diff --git a/tests/bell.test b/tests/bell.test new file mode 100644 index 0000000..97d015e --- /dev/null +++ b/tests/bell.test @@ -0,0 +1,34 @@ +# This file is a Tcl script to test out Tk's "bell" command. +# It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) bell.test 1.5 96/04/09 23:47:12 + +if {[string compare test [info procs test]] == 1} { + source defs +} + +test bell-1.1 {bell command} { + list [catch {bell a} msg] $msg +} {1 {wrong # args: should be "bell ?-displayof window?"}} +test bell-1.2 {bell command} { + list [catch {bell a b} msg] $msg +} {1 {bad option "a": must be -displayof}} +test bell-1.3 {bell command} { + list [catch {bell -displayof gorp} msg] $msg +} {1 {bad window path name "gorp"}} +test bell-1.4 {bell command} { + puts "Bell should ring now ..." + flush stdout + after 500 + bell -displayof . + after 200 + bell + after 200 + bell +} {} diff --git a/tests/bevel.tcl b/tests/bevel.tcl new file mode 100644 index 0000000..60c913a --- /dev/null +++ b/tests/bevel.tcl @@ -0,0 +1,128 @@ +# This file creates a visual test for bevels drawn around text in text +# widgets. It is part of the Tk visual test suite, which is invoked +# via the "visual" script. +# +# SCCS: @(#) bevel.tcl 1.4 96/06/24 16:48:14 + +catch {destroy .t} +toplevel .t +wm title .t "Visual Tests for Borders in Text Widgets" +wm iconname .t "Text Borders" +wm geom .t +0+0 + +text .t.t -width 60 -height 30 -setgrid true -xscrollcommand {.t.h set} \ + -font {Courier 12} \ + -yscrollcommand {.t.v set} -wrap none -relief raised -bd 2 +scrollbar .t.v -orient vertical -command ".t.t yview" +scrollbar .t.h -orient horizontal -command ".t.t xview" +button .t.quit -text Quit -command {destroy .t} +pack .t.quit -side bottom -pady 3 -ipadx 4 -ipady 2 +pack .t.h -side bottom -fill x +pack .t.v -side right -fill y +pack .t.t -expand yes -fill both +wm minsize .t 1 1 + +if {[winfo depth .t] > 1} { + .t.t tag configure r1 -relief raised -borderwidth 2 -background #b2dfee + .t.t tag configure r2 -relief raised -borderwidth 2 -background #b2dfee \ + -offset 2 + .t.t tag configure s1 -relief sunken -borderwidth 2 -background #b2dfee +} else { + .t.t tag configure r1 -relief raised -borderwidth 2 -background white + .t.t tag configure r2 -relief raised -borderwidth 2 -background white \ + -offset 2 + .t.t tag configure s1 -relief sunken -borderwidth 2 -background white +} +.t.t tag configure indent1 -lmargin1 100 +.t.t tag configure indent2 -lmargin1 200 + +.t.t insert end {This display contains a bunch of raised and sunken +regions to exercise the bevel-drawing facilities of +DisplayLineBackground. The letters have the following +significance: + +r - should appear raised +u - should appear raised and also slightly offset vertically +s - should appear sunken +n - preceding relief should extend right to end of line. +* - should appear "normal" +x - extra long lines to allow horizontal scrolling. + +Try scrolling the text both vertically and horizontally to +be sure that the bevels are still drawn correctly. + +xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + +Pass 1 (side bevels): + +} +.t.t insert end **** +.t.t insert end rrrrrrr r1 +.t.t insert end uuuu r2 +.t.t insert end ************ +.t.t insert end ssssssssssssssssss s1 +.t.t insert end \n\n**************** +.t.t insert end rrrrrrrrrrrrrrn\n r1 + +.t.t insert end "\nPass 2 (top bevels):\n\n" +.t.t insert end rrrrrrrrrrrrrr r1 +.t.t insert end rrrrr {r1 dummy} +.t.t insert end rrrrrrrrrrrrrrrrrrr r1 +.t.t insert end \n************ +.t.t insert end rrrrrrrrrrrrrrrrr r1 +.t.t insert end ***********\n +.t.t insert end rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr r1 +.t.t insert end \n\n*** +.t.t insert end rrrrrrrrrrrrrrrrrrr r1 +.t.t insert end ***********\n* +.t.t insert end rrrrrrrrr r1 +.t.t insert end ******** +.t.t insert end rrrrrrrrrrrrrrrrrrrrrrrrr r1 +.t.t insert end \n\n* +.t.t insert end *** dummy +.t.t insert end rrrrrrrrrrrrrrrrrrrrrrrrr r1 +.t.t insert end n\nrrrrrrrrrrrrrrr {r1 indent1} +.t.t insert end \n\n*** +.t.t insert end rrr r1 +.t.t insert end \n +.t.t insert end rrrr {r1 indent1} + +.t.t insert end \n\nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n\n +.t.t insert end "Pass 3 (bottom bevels):\n\n" +.t.t insert end ******* +.t.t insert end ********** dummy +.t.t insert end rrrrrrrrrrrrrrrr r1 +.t.t insert end **********\n +.t.t insert end rrrrrrrrr r1 +.t.t insert end uuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuu r2 +.t.t insert end \n******************** +.t.t insert end rrrrrrrrrrrrrrr r1 +.t.t insert end ************\n\n* +.t.t insert end rrrrrrrrrrrr r1 +.t.t insert end ******** +.t.t insert end rrrrrrrrrrrrrrrrrrrrrrrrr r1 +.t.t insert end \n***** +.t.t insert end rrrrrrrrrrrrrrrrrrrr r1 +.t.t insert end **********\n\n +.t.t insert end rrrrrrrrrrrrrrr {r1 indent1} +.t.t insert end \n** dummy +.t.t insert end ** +.t.t insert end rrrrrrrrrrrrrrrrrrrrn\n r1 +.t.t insert end \n +.t.t insert end rrrr {r1 indent1} +.t.t insert end \n*** +.t.t insert end rrr r1 + +.t.t insert end \n\nMiscellaneous:\n\n +.t.t insert end rrr r1 +.t.t insert end ***** +.t.t insert end rrr r1 +foreach i {1 2 3} { + .t.t insert end \n + .t.t insert end *** + .t.t insert end rrrrr r1 +} +.t.t insert end \n +.t.t insert end rrr r1 +.t.t insert end ***** +.t.t insert end rrr r1 diff --git a/tests/bgerror.test b/tests/bgerror.test new file mode 100644 index 0000000..72b5400 --- /dev/null +++ b/tests/bgerror.test @@ -0,0 +1,59 @@ +# This file is a Tcl script to test the bgerror command. +# It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) bgerror.test 1.1 97/08/06 09:28:30 + +if {[info commands test] == ""} { + source defs +} + + +test bgerror-1.1 {bgerror / tkerror compat} { + set errRes {} + proc tkerror {err} { + global errRes; + set errRes $err; + } + after 0 {error err1} + vwait errRes; + set errRes; +} err1 + +test bgerror-1.2 {bgerror / tkerror compat / accumulation} { + set errRes {} + proc tkerror {err} { + global errRes; + lappend errRes $err; + } + after 0 {error err1} + after 0 {error err2} + after 0 {error err3} + update + set errRes; +} {err1 err2 err3} + +test bgerror-1.3 {bgerror / tkerror compat / accumulation / break} { + set errRes {} + proc tkerror {err} { + global errRes; + lappend errRes $err; + return -code break "skip!"; + } + after 0 {error err1} + after 0 {error err2} + after 0 {error err3} + update + set errRes; +} err1 + +catch {rename tkerror {}} + +# some testing of the default error dialog +# would be needed too, but that's not easy at all +# to emulate. + diff --git a/tests/bind.test b/tests/bind.test new file mode 100644 index 0000000..18de465 --- /dev/null +++ b/tests/bind.test @@ -0,0 +1,2530 @@ +# This file is a Tcl script to test out Tk's "bind" and "bindtags" +# commands plus the procedures in tkBind.c. It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) bind.test 1.39 97/07/01 18:01:05 + +if {[string compare test [info procs test]] != 0} { + source defs +} + +catch {destroy .b} +toplevel .b -width 100 -height 50 +wm geom .b +0+0 +update idletasks + +proc setup {} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + pack .b.f + focus -force .b.f + foreach p [event info] {event delete $p} + update +} +setup + +foreach i [bind Test] { + bind Test $i {} +} +foreach i [bind all] { + bind all $i {} +} + +test bind-1.1 {bind command} { + list [catch {bind} msg] $msg +} {1 {wrong # args: should be "bind window ?pattern? ?command?"}} +test bind-1.2 {bind command} { + list [catch {bind a b c d} msg] $msg +} {1 {wrong # args: should be "bind window ?pattern? ?command?"}} +test bind-1.3 {bind command} { + list [catch {bind .gorp} msg] $msg +} {1 {bad window path name ".gorp"}} +test bind-1.4 {bind command} { + list [catch {bind foo} msg] $msg +} {0 {}} +test bind-1.5 {bind command} { + list [catch {bind .b <gorp-> {}} msg] $msg +} {0 {}} +test bind-1.6 {bind command} { + catch {destroy .b.f} + frame .b.f + bind .b.f <Enter> {test script} + set result [bind .b.f <Enter>] + bind .b.f <Enter> {} + list $result [bind .b.f <Enter>] +} {{test script} {}} +test bind-1.7 {bind command} { + catch {destroy .b.f} + frame .b.f + bind .b.f <Enter> {test script} + bind .b.f <Enter> {+more text} + bind .b.f <Enter> +} {test script +more text} +test bind-1.8 {bind command} { + list [catch {bind .b <gorp-> {test script}} msg] $msg [bind .b] +} {1 {bad event type or keysym "gorp"} {}} +test bind-1.9 {bind command} { + list [catch {bind .b <gorp->} msg] $msg +} {0 {}} +test bind-1.10 {bind command} { + catch {destroy .b.f} + frame .b.f + bind .b.f <Enter> {script 1} + bind .b.f <Leave> {script 2} + bind .b.f a {script for a} + bind .b.f b {script for b} + lsort [bind .b.f] +} {<Enter> <Leave> a b} + +test bind-2.1 {bindtags command} { + list [catch {bindtags} msg] $msg +} {1 {wrong # args: should be "bindtags window ?tags?"}} +test bind-2.2 {bindtags command} { + list [catch {bindtags a b c} msg] $msg +} {1 {wrong # args: should be "bindtags window ?tags?"}} +test bind-2.3 {bindtags command} { + list [catch {bindtags .foo} msg] $msg +} {1 {bad window path name ".foo"}} +test bind-2.4 {bindtags command} { + bindtags .b +} {.b Toplevel all} +test bind-2.5 {bindtags command} { + catch {destroy .b.f} + frame .b.f + bindtags .b.f +} {.b.f Frame .b all} +test bind-2.6 {bindtags command} { + catch {destroy .b.f} + frame .b.f + bindtags .b.f {{x y z} b c d} + bindtags .b.f +} {{x y z} b c d} +test bind-2.7 {bindtags command} { + catch {destroy .b.f} + frame .b.f + bindtags .b.f {x y z} + bindtags .b.f {} + bindtags .b.f +} {.b.f Frame .b all} +test bind-2.8 {bindtags command} { + catch {destroy .b.f} + frame .b.f + bindtags .b.f {x y z} + bindtags .b.f {a b c d} + bindtags .b.f +} {a b c d} +test bind-2.9 {bindtags command} { + catch {destroy .b.f} + frame .b.f + bindtags .b.f {a b c} + list [catch {bindtags .b.f "\{"} msg] $msg [bindtags .b.f] +} {1 {unmatched open brace in list} {.b.f Frame .b all}} +test bind-2.10 {bindtags command} { + catch {destroy .b.f} + frame .b.f + bindtags .b.f {a b c} + list [catch {bindtags .b.f "a .gorp b"} msg] $msg [bindtags .b.f] +} {0 {} {a .gorp b}} +test bind-3.1 {TkFreeBindingTags procedure} { + catch {destroy .b.f} + frame .b.f + bindtags .b.f "a b c d" + destroy .b.f +} {} +test bind-3.2 {TkFreeBindingTags procedure} { + catch {destroy .b.f} + frame .b.f + catch {bindtags .b.f "a .gorp b .b.f"} + destroy .b.f +} {} + +bind all <Enter> {lappend x "%W enter all"} +bind Test <Enter> {lappend x "%W enter frame"} +bind Toplevel <Enter> {lappend x "%W enter toplevel"} +bind xyz <Enter> {lappend x "%W enter xyz"} +bind {a b} <Enter> {lappend x "%W enter {a b}"} +bind .b <Enter> {lappend x "%W enter .b"} +test bind-4.1 {TkBindEventProc procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + pack .b.f + update + bind .b.f <Enter> {lappend x "%W enter .b.f"} + set x {} + event gen .b.f <Enter> + set x +} {{.b.f enter .b.f} {.b.f enter frame} {.b.f enter .b} {.b.f enter all}} +test bind-4.2 {TkBindEventProc procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + pack .b.f + update + bind .b.f <Enter> {lappend x "%W enter .b.f"} + bindtags .b.f {.b.f {a b} xyz} + set x {} + event gen .b.f <Enter> + set x +} {{.b.f enter .b.f} {.b.f enter {a b}} {.b.f enter xyz}} +test bind-4.3 {TkBindEventProc procedure} { + set x {} + event gen .b <Enter> + set x +} {{.b enter .b} {.b enter toplevel} {.b enter all}} +test bind-4.4 {TkBindEventProc procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + pack .b.f + update + bindtags .b.f {.b.f .b.f2 .b.f3} + frame .b.f3 -width 50 -height 50 + pack .b.f3 + bind .b.f <Enter> {lappend x "%W enter .b.f"} + bind .b.f3 <Enter> {lappend x "%W enter .b.f3"} + set x {} + event gen .b.f <Enter> + destroy .b.f3 + set x +} {{.b.f enter .b.f} {.b.f enter .b.f3}} +test bind-4.5 {TkBindEventProc procedure} { + # This tests memory allocation for objPtr; it won't serve any useful + # purpose unless run with some sort of allocation checker turned on. + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + pack .b.f + update + bindtags .b.f {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} + event gen .b.f <Enter> +} {} +bind all <Enter> {} +bind Test <Enter> {} +bind Toplevel <Enter> {} +bind xyz <Enter> {} +bind {a b} <Enter> {} +bind .b <Enter> {} + +test bind-5.1 {Tk_CreateBindingTable procedure} { + catch {destroy .b.c} + canvas .b.c + .b.c bind foo +} {} + + +test bind-6.1 {Tk_DeleteBindTable procedure} { + catch {destroy .b.c} + canvas .b.c + .b.c bind foo <1> {string 1} + .b.c create rectangle 0 0 100 100 + .b.c bind 1 <2> {string 2} + destroy .b.c +} {} +test bind-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} { + catch {interp delete foo} + interp create foo + foo eval { + load {} Tk + load {} Tktest + wm geometry . +0+0 + frame .t -width 50 -height 50 + bindtags .t {a b c d} + pack .t + update + set x {} + testcbind a <1> "lappend x a1; destroy ." "lappend x bye.a1" + bind b <1> "lappend x b1" + testcbind c <1> "lappend x c1" "lappend x bye.c1" + testcbind c <2> "lappend x all2" "lappend x bye.all2" + event gen .t <1> + } + set x [foo eval set x] + interp delete foo + set x +} {a1 bye.all2 bye.a1 b1 bye.c1} + +test bind-7.1 {Tk_CreateBinding procedure: error} { + catch {destroy .b.c} + canvas .b.c + list [catch {.b.c bind foo <} msg] $msg +} {1 {no event type or button # or keysym}} +test bind-7.2 {Tk_CreateBinding procedure: replace existing C binding} { + catch {destroy .b.f} + frame .b.f + testcbind .b.f <1> "xyz" "lappend x bye.1" + set x {} + bind .b.f <1> "abc" + destroy .b.f + set x +} {bye.1} +test bind-7.3 {Tk_CreateBinding procedure: append} { + catch {destroy .b.c} + canvas .b.c + .b.c bind foo <1> "button 1" + .b.c bind foo <1> "+more button 1" + .b.c bind foo <1> +} {button 1 +more button 1} +test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} { + catch {destroy .b.c} + canvas .b.c + .b.c bind foo <1> "+button 1" + .b.c bind foo <1> +} {button 1} + +test bind-8.1 {TkCreateBindingProcedure: error} { + list [catch {testcbind . <xyz> "xyz"} msg] $msg +} {1 {bad event type or keysym "xyz"}} +test bind-8.2 {TkCreateBindingProcedure: new binding} { + catch {destroy .b.f} + frame .b.f + testcbind .b.f <1> "lappend x 1" "lappend x bye.1" + set x {} + event gen .b.f <1> + destroy .b.f + set x +} {bye.1} +test bind-8.3 {TkCreateBindingProcedure: replace existing} { + catch {destroy .b.f} + frame .b.f + pack .b.f + set x {} + testcbind .b.f <1> "lappend x old1" "lappend x bye.old1" + testcbind .b.f <1> "lappend x new1" "lappend x bye.new1" + set x +} {bye.old1} +test bind-8.4 {TkCreateBindingProcedure: replace existing while pending} { + catch {destroy .b.f} + frame .b.f + pack .b.f + update + testcbind .b.f <1> "lappend x .b.f; testcbind Frame <1> {lappend x Frame}" + testcbind Frame <1> "lappend x never" + set x {} + event gen .b.f <1> + bind .b.f <1> {} + set x +} {.b.f Frame} + +test bind-9.1 {Tk_DeleteBinding procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + list [catch {bind .b.f <} msg] $msg +} {0 {}} +test bind-9.2 {Tk_DeleteBinding procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + foreach i {a b c d} { + bind .b.f $i "binding for $i" + } + set result {} + foreach i {b d a c} { + bind .b.f $i {} + lappend result [lsort [bind .b.f]] + } + set result +} {{a c d} {a c} c {}} +test bind-9.3 {Tk_DeleteBinding procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + foreach i {<1> <Meta-1> <Control-1> <Double-Alt-1>} { + bind .b.f $i "binding for $i" + } + set result {} + foreach i {<Control-1> <Double-Alt-1> <1> <Meta-1>} { + bind .b.f $i {} + lappend result [lsort [bind .b.f]] + } + set result +} {{<Button-1> <Double-Alt-Button-1> <Meta-Button-1>} {<Button-1> <Meta-Button-1>} <Meta-Button-1> {}} +test bind-9.4 {Tk_DeleteBinding procedure: pending bindings delete later} { + catch {destroy .b.f} + frame .b.f + pack .b.f + update + bindtags .b.f {a b c} + testcbind a <1> {lappend x a1; bind c <1> {}; bind c <2> {}} {lappend x bye.a1} + bind b <1> {lappend x b1} + testcbind c <1> {lappend x c1} {lappend x bye.c1} + testcbind c <2> {lappend x c2} {lappend x bye.c2} + set x {} + event gen .b.f <1> + bind a <1> {} + bind b <1> {} + set x +} {a1 bye.c2 b1 bye.c1 bye.a1} + +test bind-10.1 {Tk_GetBinding procedure} { + catch {destroy .b.c} + canvas .b.c + list [catch {.b.c bind foo <} msg] $msg +} {1 {no event type or button # or keysym}} +test bind-10.2 {Tk_GetBinding procedure} { + catch {destroy .b.c} + canvas .b.c + .b.c bind foo a Test + .b.c bind foo a +} {Test} +test bind-10.3 {Tk_GetBinding procedure: C binding} { + catch {destroy .b.f} + frame .b.f + testcbind .b.f <1> "foo" + list [bind .b.f] [bind .b.f <1>] +} {<Button-1> {}} + +test bind-11.1 {Tk_GetAllBindings procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + foreach i "! a \\\{ ~ <Delete> <space> <<Paste>> <Tab> <Linefeed> <less> <Meta-a> <Acircumflex>" { + bind .b.f $i Test + } + lsort [bind .b.f] +} {! <<Paste>> <Key-Acircumflex> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-less> <Key-space> <Meta-Key-a> a \{ ~} +test bind-11.2 {Tk_GetAllBindings procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + foreach i "<Double-1> <Triple-1> <Meta-Control-a> <Double-Alt-Enter> <1>" { + bind .b.f $i Test + } + lsort [bind .b.f] +} {<Button-1> <Control-Meta-Key-a> <Double-Alt-Enter> <Double-Button-1> <Triple-Button-1>} +test bind-11.3 {Tk_GetAllBindings procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + foreach i "<Double-Triple-1> abcd a<Leave>b" { + bind .b.f $i Test + } + lsort [bind .b.f] +} {<Triple-Button-1> a<Leave>b abcd} + + +test bind-12.1 {Tk_DeleteAllBindings procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + destroy .b.f +} {} +test bind-12.2 {Tk_DeleteAllBindings procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + foreach i "a b c <Meta-1> <Alt-a> <Control-a>" { + bind .b.f $i x + } + destroy .b.f +} {} +test bind-12.3 {Tk_DeleteAllBindings procedure: pending bindings deleted later} { + catch {destroy .b.f} + frame .b.f + pack .b.f + update + testcbind .b.f <1> {lappend x before; event gen .b.f <2>; lappend x after} {lappend x bye.f1} + testcbind .b.f <2> {destroy .b.f} {lappend x bye.f2} + bind .b.f <Destroy> {lappend x fDestroy} + testcbind .b.f <3> {foo} {lappend x bye.f3} + set x {} + event gen .b.f <1> + set x +} {before fDestroy bye.f3 bye.f2 after bye.f1} + +bind Test <KeyPress> {lappend x "%W %K Test press any"} +bind all <KeyPress> {lappend x "%W %K all press any"} +bind Test a {lappend x "%W %K Test press a"} +bind all x {lappend x "%W %K all press x"} + +test bind-13.1 {Tk_BindEvent procedure} { + setup + bind .b.f a {lappend x "%W %K .b.f press a"} + set x {} + event gen .b.f <Key-a> + event gen .b.f <Key-b> + event gen .b.f <Key-x> + set x +} {{.b.f a .b.f press a} {.b.f a Test press a} {.b.f a all press any} {.b.f b Test press any} {.b.f b all press any} {.b.f x Test press any} {.b.f x all press x}} + +bind Test <KeyPress> {lappend x "%W %K Test press any"; break} +bind all <KeyPress> {continue; lappend x "%W %K all press any"} + +test bind-13.2 {Tk_BindEvent procedure} { + setup + bind .b.f b {lappend x "%W %K .b.f press a"} + set x {} + event gen .b.f <Key-b> + set x +} {{.b.f b .b.f press a} {.b.f b Test press any}} +if {[info procs bgerror] == "bgerror"} { + rename bgerror {} +} +proc bgerror args {} +bind Test <KeyPress> {lappend x "%W %K Test press any"; error Test} +test bind-13.3 {Tk_BindEvent procedure} { + setup + bind .b.f b {lappend x "%W %K .b.f press a"} + set x {} + event gen .b.f <Key-b> + update + list $x $errorInfo +} {{{.b.f b .b.f press a} {.b.f b Test press any}} {Test + while executing +"error Test" + (command bound to event)}} +rename bgerror {} +test bind-13.4 {Tk_BindEvent procedure} { + proc foo {} { + set x 44 + event gen .b.f <Key-a> + } + setup + bind .b.f a {lappend x "%W %K .b.f press a"} + set x {} + foo + set x +} {{.b.f a .b.f press a} {.b.f a Test press a}} +test bind-13.5 {Tk_BindEvent procedure} { + bind all <Destroy> {lappend x "%W destroyed"} + set x {} + list [catch {frame .b.g -gorp foo} msg] $msg $x +} {1 {unknown option "-gorp"} {{.b.g destroyed}}} +foreach i [bind all] { + bind all $i {} +} +foreach i [bind Test] { + bind Test $i {} +} +test bind-13.6 {Tk_BindEvent procedure} { + setup + bind .b.f z {lappend x "%W z (.b.f binding)"} + bind Test z {lappend x "%W z (.b.f binding)"} + bind all z {bind .b.f z {}; lappend x "%W z (.b.f binding)"} + set x {} + event gen .b.f <Key-z> + bind Test z {} + bind all z {} + set x +} {{.b.f z (.b.f binding)} {.b.f z (.b.f binding)} {.b.f z (.b.f binding)}} +test bind-13.7 {Tk_BindEvent procedure} { + setup + bind .b.f z {lappend x "%W z (.b.f binding)"} + bind Test z {lappend x "%W z (.b.f binding)"} + bind all z {destroy .b.f; lappend x "%W z (.b.f binding)"} + set x {} + event gen .b.f <Key-z> + bind Test z {} + bind all z {} + set x +} {{.b.f z (.b.f binding)} {.b.f z (.b.f binding)} {.b.f z (.b.f binding)}} +test bind-13.8 {Tk_BindEvent procedure} { + setup + bind .b.f <1> {lappend x "%W z (.b.f <1> binding)"} + bind .b.f <ButtonPress> {lappend x "%W z (.b.f <ButtonPress> binding)"} + set x {} + event gen .b.f <Button-1> + event gen .b.f <Button-2> + set x +} {{.b.f z (.b.f <1> binding)} {.b.f z (.b.f <ButtonPress> binding)}} +test bind-13.9 {Tk_BindEvent procedure: ignore NotifyInferior} { + setup + bind .b.f <Enter> "lappend x Enter%#" + bind .b.f <Leave> "lappend x Leave%#" + set x {} + event gen .b.f <Enter> -serial 100 -detail NotifyAncestor + event gen .b.f <Enter> -serial 101 -detail NotifyInferior + event gen .b.f <Leave> -serial 102 -detail NotifyAncestor + event gen .b.f <Leave> -serial 103 -detail NotifyInferior + set x +} {Enter100 Leave102} +test bind-13.10 {Tk_BindEvent procedure: collapse Motions} { + setup + bind .b.f <Motion> "lappend x Motion%#(%x,%y)" + set x {} + event gen .b.f <Motion> -serial 100 -x 100 -y 200 -when tail + update + event gen .b.f <Motion> -serial 101 -x 200 -y 300 -when tail + event gen .b.f <Motion> -serial 102 -x 300 -y 400 -when tail + update + set x +} {Motion100(100,200) Motion102(300,400)} +test bind-13.11 {Tk_BindEvent procedure: collapse repeating modifiers} { + setup + bind .b.f <Key> "lappend x %K%#" + bind .b.f <KeyRelease> "lappend x %K%#" + event gen .b.f <Key-Shift_L> -serial 100 -when tail + event gen .b.f <KeyRelease-Shift_L> -serial 101 -when tail + event gen .b.f <Key-Shift_L> -serial 102 -when tail + event gen .b.f <KeyRelease-Shift_L> -serial 103 -when tail + update +} {} +test bind-13.12 {Tk_BindEvent procedure: valid key detail} { + setup + bind .b.f <Key> "lappend x Key%K" + bind .b.f <KeyRelease> "lappend x Release%K" + set x {} + event gen .b.f <Key> -keysym a + event gen .b.f <KeyRelease> -keysym a + set x +} {Keya Releasea} +test bind-13.13 {Tk_BindEvent procedure: invalid key detail} { + setup + bind .b.f <Key> "lappend x Key%K" + bind .b.f <KeyRelease> "lappend x Release%K" + set x {} + event gen .b.f <Key> -keycode 0 + event gen .b.f <KeyRelease> -keycode 0 + set x +} {Key?? Release??} +test bind-13.14 {Tk_BindEvent procedure: button detail} { + setup + bind .b.f <Button> "lappend x Button%b" + bind .b.f <ButtonRelease> "lappend x Release%b" + set x {} + event gen .b.f <Button> -button 1 + event gen .b.f <ButtonRelease> -button 3 + set x +} {Button1 Release3} +test bind-13.15 {Tk_BindEvent procedure: virtual detail} { + setup + bind .b.f <<Paste>> "lappend x Paste" + set x {} + event gen .b.f <<Paste>> + set x +} {Paste} +test bind-13.16 {Tk_BindEvent procedure: virtual event in event stream} { + setup + bind .b.f <<Paste>> "lappend x Paste" + set x {} + event gen .b.f <<Paste>> + set x +} {Paste} +test bind-13.17 {Tk_BindEvent procedure: match detail physical} { + setup + bind .b.f <Button-2> {set x Button-2} + event add <<Paste>> <Button-2> + bind .b.f <<Paste>> {set x Paste} + set x {} + event gen .b.f <Button-2> + set x +} {Button-2} +test bind-13.18 {Tk_BindEvent procedure: no match detail physical} { + setup + event add <<Paste>> <Button-2> + bind .b.f <<Paste>> {set x Paste} + set x {} + event gen .b.f <Button-2> + set x +} {Paste} +test bind-13.19 {Tk_BindEvent procedure: match detail virtual} { + setup + event add <<Paste>> <Button-2> + bind .b.f <<Paste>> "lappend x Paste" + set x {} + event gen .b.f <Button-2> + set x +} {Paste} +test bind-13.20 {Tk_BindEvent procedure: no match detail virtual} { + setup + event add <<Paste>> <Button-2> + bind .b.f <<Paste>> "lappend x Paste" + set x {} + event gen .b.f <Button> + set x +} {} +test bind-13.21 {Tk_BindEvent procedure: match no-detail physical} { + setup + bind .b.f <Button> {set x Button} + event add <<Paste>> <Button> + bind .b.f <<Paste>> {set x Paste} + set x {} + event gen .b.f <Button-2> + set x +} {Button} +test bind-13.22 {Tk_BindEvent procedure: no match no-detail physical} { + setup + event add <<Paste>> <Button> + bind .b.f <<Paste>> {set x Paste} + set x {} + event gen .b.f <Button-2> + set x +} {Paste} +test bind-13.23 {Tk_BindEvent procedure: match no-detail virtual} { + setup + event add <<Paste>> <Button> + bind .b.f <<Paste>> "lappend x Paste" + set x {} + event gen .b.f <Button-2> + set x +} {Paste} +test bind-13.24 {Tk_BindEvent procedure: no match no-detail virtual} { + setup + event add <<Paste>> <Key> + bind .b.f <<Paste>> "lappend x Paste" + set x {} + event gen .b.f <Button> + set x +} {} +test bind-13.25 {Tk_BindEvent procedure: precedence} { + setup + event add <<Paste>> <Button-2> + event add <<Copy>> <Button> + bind .b.f <Button-2> "lappend x Button-2" + bind .b.f <<Paste>> "lappend x Paste" + bind .b.f <Button> "lappend x Button" + bind .b.f <<Copy>> "lappend x Copy" + + set x {} + event gen .b.f <Button-2> + bind .b.f <Button-2> {} + event gen .b.f <Button-2> + bind .b.f <<Paste>> {} + event gen .b.f <Button-2> + bind .b.f <Button> {} + event gen .b.f <Button-2> + bind .b.f <<Copy>> {} + event gen .b.f <Button-2> + set x +} {Button-2 Paste Button Copy} +test bind-13.26 {Tk_BindEvent procedure: no detail virtual pattern list} { + setup + bind .b.f <Button-2> {set x Button-2} + set x {} + event gen .b.f <Button-2> + set x +} {Button-2} +test bind-13.27 {Tk_BindEvent procedure: detail virtual pattern list} { + setup + event add <<Paste>> <Button-2> + bind .b.f <<Paste>> {set x Paste} + set x {} + event gen .b.f <Button-2> + set x +} {Paste} +test bind-13.28 {Tk_BindEvent procedure: no no-detail virtual pattern list} { + setup + bind .b.f <Button> {set x Button} + set x {} + event gen .b.f <Button-2> + set x +} {Button} +test bind-13.29 {Tk_BindEvent procedure: no-detail virtual pattern list} { + setup + event add <<Paste>> <Button> + bind .b.f <<Paste>> {set x Paste} + set x {} + event gen .b.f <Button-2> + set x +} {Paste} +test bind-13.30 {Tk_BindEvent procedure: no match} { + setup + event gen .b.f <Button-2> +} {} +test bind-13.31 {Tk_BindEvent procedure: match} { + setup + bind .b.f <Button-2> {set x Button-2} + set x {} + event gen .b.f <Button-2> + set x +} {Button-2} +test bind-13.32 {Tk_BindEvent procedure: many C bindings cause realloc} { + setup + bindtags .b.f {a b c d e f g h i j k l m n o p} + foreach p [bindtags .b.f] { + testcbind $p <1> "lappend x $p" + } + set x {} + event gen .b.f <1> + foreach p [bindtags .b.f] { + bind $p <1> {} + } + set x +} {a b c d e f g h i j k l m n o p} +test bind-13.33 {Tk_BindEvent procedure: multiple tags} { + setup + bind .b.f <Button-2> {lappend x .b.f} + bind Test <Button-2> {lappend x Button} + set x {} + event gen .b.f <Button-2> + bind Test <Button-2> {} + set x +} {.b.f Button} +test bind-13.34 {Tk_BindEvent procedure: execute C binding} { + setup + testcbind .b.f <1> {lappend x 1} + set x {} + event gen .b.f <1> + set x +} {1} +test bind-13.35 {Tk_BindEvent procedure: pending list marked deleted} { + setup + testcbind Test <1> {lappend x Test} {lappend x Deleted} + bind .b.f <1> {lappend x .b.f; destroy .b.f} + set x {} + event gen .b.f <1> + set y [list $x [bind Test]] + bind Test <1> {} + set y +} {.b.f <Button-1>} +test bind-13.36 {Tk_BindEvent procedure: C binding marked deleted} { + setup + testcbind Test <1> {lappend x Test} {lappend x Deleted} + bind .b.f <1> {lappend x .b.f; bind Test <1> {}; lappend x after} + set x {} + event gen .b.f <1> + set x +} {.b.f after Deleted} +test bind-13.37 {Tk_BindEvent procedure: C binding gets to run} { + setup + testcbind Test <1> {lappend x Test} + bind .b.f <1> {lappend x .b.f} + set x {} + event gen .b.f <1> + bind Test <1> {} + set x +} {.b.f Test} +test bind-13.38 {Tk_BindEvent procedure: C binding deleted, refcount == 0} { + setup + testcbind .b.f <1> {lappend x hi; bind .b.f <1> {}} {lappend x bye} + set x {} + event gen .b.f <1> + set x +} {hi bye} +test bind-13.39 {Tk_BindEvent procedure: C binding deleted, refcount != 0} { + setup + testcbind .b.f <1> { + lappend x before$n + if {$n==0} { + bind .b.f <1> {} + } else { + set n [expr $n-1] + event gen .b.f <1> + } + lappend x after$n + } {lappend x Deleted} + set n 3 + set x {} + event gen .b.f <1> + set x +} {before3 before2 before1 before0 after0 after0 after0 after0 Deleted} +test bind-13.40 {Tk_BindEvent procedure: continue in script} { + setup + bind .b.f <Button-2> {lappend x b1; continue; lappend x b2} + bind Test <Button-2> {lappend x B1; continue; lappend x B2} + set x {} + event gen .b.f <Button-2> + bind Test <Button-2> {} + set x +} {b1 B1} +test bind-13.41 {Tk_BindEvent procedure: continue in script} { + setup + testcbind .b.f <Button-2> {lappend x b1; continue; lappend x b2} + testcbind Test <Button-2> {lappend x B1; continue; lappend x B2} + set x {} + event gen .b.f <Button-2> + bind Test <Button-2> {} + set x +} {b1 B1} +test bind-13.42 {Tk_BindEvent procedure: break in script} { + setup + bind .b.f <Button-2> {lappend x b1; break; lappend x b2} + bind Test <Button-2> {lappend x B1; break; lappend x B2} + set x {} + event gen .b.f <Button-2> + bind Test <Button-2> {} + set x +} {b1} +test bind-13.43 {Tk_BindEvent procedure: break in script} { + setup + testcbind .b.f <Button-2> {lappend x b1; break; lappend x b2} + testcbind Test <Button-2> {lappend x B1; break; lappend x B2} + set x {} + event gen .b.f <Button-2> + bind Test <Button-2> {} + set x +} {b1} + +proc bgerror msg { + global x + lappend x $msg +} +test bind-13.44 {Tk_BindEvent procedure: error in script} { + setup + bind .b.f <Button-2> {lappend x b1; blap} + bind Test <Button-2> {lappend x B1} + set x {} + event gen .b.f <Button-2> + update + bind Test <Button-2> {} + set x +} {b1 {invalid command name "blap"}} +test bind-13.45 {Tk_BindEvent procedure: error in script} { + setup + testcbind .b.f <Button-2> {lappend x b1; blap} + testcbind Test <Button-2> {lappend x B1} + set x {} + event gen .b.f <Button-2> + update + bind Test <Button-2> {} + set x +} {b1 {invalid command name "blap"}} + +test bind-14.1 {TkBindDeadWindow: no C bindings pending} { + setup + bind .b.f <1> x + testcbind .b.f <2> y + destroy .b.f +} {} +test bind-14.2 {TkBindDeadWindow: is called after <Destroy>} { + setup + testcbind .b.f <Destroy> "lappend x .b.f" + testcbind Test <Destroy> "lappend x Test" + set x {} + destroy .b.f + bind Test <Destroy> {} + set x +} {.b.f Test} +test bind-14.3 {TkBindDeadWindow: pending C bindings} { + setup + bindtags .b.f {a b c d} + testcbind a <1> "lappend x a1" "lappend x bye.a1" + testcbind b <1> "destroy .b.f; lappend x b1" "lappend x bye.b1" + testcbind c <1> "lappend x c1" "lappend x bye.c1" + testcbind d <1> "lappend x d1" "lappend x bye.d1" + bind a <2> "event gen .b.f <1>" + testcbind b <2> "lappend x b2" "lappend x bye.b2" + testcbind c <2> "lappend x c2" "lappend x bye.d2" + bind d <2> "lappend x d2" + testcbind a <3> "event gen .b.f <2>" + set x {} + event gen .b.f <3> + set y $x + foreach tag {a b c d} { + foreach event {<1> <2> <3>} { + bind $tag $event {} + } + } + set y +} {a1 b1 d2} + +test bind-15.1 {MatchPatterns procedure, ignoring type mismatches} { + setup + bind .b.f ab {set x 1} + set x 0 + event gen .b.f <Key-a> + event gen .b.f <KeyRelease-a> + event gen .b.f <Key-b> + event gen .b.f <KeyRelease-b> + set x +} 1 +test bind-15.2 {MatchPatterns procedure, ignoring type mismatches} { + setup + bind .b.f ab {set x 1} + set x 0 + event gen .b.f <Key-a> + event gen .b.f <Enter> + event gen .b.f <KeyRelease-a> + event gen .b.f <Leave> + event gen .b.f <Key-b> + event gen .b.f <KeyRelease-b> + set x +} 1 +test bind-15.3 {MatchPatterns procedure, ignoring type mismatches} { + setup + bind .b.f ab {set x 1} + set x 0 + event gen .b.f <Key-a> + event gen .b.f <Button-1> + event gen .b.f <Key-b> + set x +} 0 +test bind-15.4 {MatchPatterns procedure, ignoring type mismatches} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> + event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> + set x +} 1 +test bind-15.5 {MatchPatterns procedure, ignoring type mismatches} { + setup + bind .b.f <Double-ButtonRelease> {set x 1} + set x 0 + event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> + event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> + set x +} 1 +test bind-15.6 {MatchPatterns procedure, ignoring type mismatches} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-1> + event gen .b.f <Key-a> + event gen .b.f <ButtonRelease-1> + event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> + set x +} 0 +test bind-15.7 {MatchPatterns procedure, ignoring type mismatches} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-1> + event gen .b.f <Key-Shift_L> + event gen .b.f <ButtonRelease-1> + event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> + set x +} 1 +test bind-15.8 {MatchPatterns procedure, ignoring type mismatches} { + setup + bind .b.f ab {set x 1} + set x 0 + event gen .b.f <Key-a> + event gen .b.f <Key-c> + event gen .b.f <Key-b> + set x +} 0 +test bind-15.9 {MatchPatterns procedure, modifier checks} { + setup + bind .b.f <M1-M2-Key> {set x 1} + set x 0 + event gen .b.f <Key-a> -state 0x18 + set x +} 1 +test bind-15.10 {MatchPatterns procedure, modifier checks} { + setup + bind .b.f <M1-M2-Key> {set x 1} + set x 0 + event gen .b.f <Key-a> -state 0xfc + set x +} 1 +test bind-15.11 {MatchPatterns procedure, modifier checks} { + setup + bind .b.f <M1-M2-Key> {set x 1} + set x 0 + event gen .b.f <Key-a> -state 0x8 + set x +} 0 +test bind-15.12 {MatchPatterns procedure, ignore modifier presses and releases} {nonPortable} { + # This test is non-portable because the Shift_L keysym may behave + # differently on some platforms. + setup + bind .b.f aB {set x 1} + set x 0 + event gen .b.f <Key-a> + event gen .b.f <Key-Shift_L> + event gen .b.f <Key-b> -state 1 + set x +} 1 +test bind-15.13 {MatchPatterns procedure, checking detail} { + setup + bind .b.f ab {set x 1} + set x 0 + event gen .b.f <Key-a> + event gen .b.f <Key-c> + set x +} 0 +test bind-15.14 {MatchPatterns procedure, checking "nearby"} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-2> + event gen .b.f <Button-1> -x 30 -y 40 + event gen .b.f <Button-1> -x 31 -y 39 + set x +} 1 +test bind-15.15 {MatchPatterns procedure, checking "nearby"} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-2> + event gen .b.f <Button-1> -x 30 -y 40 + event gen .b.f <Button-1> -x 29 -y 41 + set x +} 1 +test bind-15.16 {MatchPatterns procedure, checking "nearby"} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-2> + event gen .b.f <Button-1> -x 30 -y 40 + event gen .b.f <Button-1> -x 40 -y 40 + set x +} 0 +test bind-15.17 {MatchPatterns procedure, checking "nearby"} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-2> + event gen .b.f <Button-1> -x 30 -y 40 + event gen .b.f <Button-1> -x 20 -y 40 + set x +} 0 +test bind-15.18 {MatchPatterns procedure, checking "nearby"} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-2> + event gen .b.f <Button-1> -x 30 -y 40 + event gen .b.f <Button-1> -x 30 -y 30 + set x +} 0 +test bind-15.19 {MatchPatterns procedure, checking "nearby"} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-2> + event gen .b.f <Button-1> -x 30 -y 40 + event gen .b.f <Button-1> -x 30 -y 50 + set x +} 0 +test bind-15.20 {MatchPatterns procedure, checking "nearby"} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-2> + event gen .b.f <Button-1> -time 300 + event gen .b.f <Button-1> -time 700 + set x +} 1 +test bind-15.21 {MatchPatterns procedure, checking "nearby"} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-2> + event gen .b.f <Button-1> -time 300 + event gen .b.f <Button-1> -time 900 + set x +} 0 +test bind-15.22 {MatchPatterns procedure, time wrap-around} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-1> -time [expr -100] + event gen .b.f <Button-1> -time 200 + set x +} 1 +test bind-15.23 {MatchPatterns procedure, time wrap-around} { + setup + bind .b.f <Double-1> {set x 1} + set x 0 + event gen .b.f <Button-1> -time -100 + event gen .b.f <Button-1> -time 500 + set x +} 0 +test bind-15.24 {MatchPatterns procedure, virtual event} { + setup + event add <<Paste>> <Button-1> + bind .b.f <<Paste>> {lappend x paste} + set x {} + event gen .b.f <Button-1> + set x +} {paste} +test bind-15.25 {MatchPatterns procedure, reject a virtual event} { + setup + event add <<Paste>> <Shift-Button-1> + bind .b.f <<Paste>> {lappend x paste} + set x {} + event gen .b.f <Button-1> + set x +} {} +test bind-15.26 {MatchPatterns procedure, reject a virtual event} { + setup + event add <<V1>> <Button> + event add <<V2>> <Button-1> + event add <<V3>> <Shift-Button-1> + bind .b.f <<V2>> "lappend x V2%#" + set x {} + event gen .b.f <Button> -serial 101 + event gen .b.f <Button-1> -serial 102 + event gen .b.f <Shift-Button-1> -serial 103 + bind .b.f <Shift-Button-1> "lappend x Shift-Button-1" + event gen .b.f <Button> -serial 104 + event gen .b.f <Button-1> -serial 105 + event gen .b.f <Shift-Button-1> -serial 106 + set x +} {V2102 V2103 V2105 Shift-Button-1} +test bind-15.27 {MatchPatterns procedure, conflict resolution} { + setup + bind .b.f <KeyPress> {set x 0} + bind .b.f a {set x 1} + set x none + event gen .b.f <Key-a> + set x +} 1 +test bind-15.28 {MatchPatterns procedure, conflict resolution} { + setup + bind .b.f <KeyPress> {set x 0} + bind .b.f a {set x 1} + set x none + event gen .b.f <Key-b> + set x +} 0 +test bind-15.29 {MatchPatterns procedure, conflict resolution} { + setup + bind .b.f <KeyPress> {lappend x 0} + bind .b.f a {lappend x 1} + bind .b.f ba {lappend x 2} + set x none + event gen .b.f <Key-b> + event gen .b.f <KeyRelease-b> + event gen .b.f <Key-a> + set x +} {none 0 2} +test bind-15.30 {MatchPatterns procedure, conflict resolution} { + setup + bind .b.f <ButtonPress> {set x 0} + bind .b.f <1> {set x 1} + set x none + event gen .b.f <Button-1> + set x +} 1 +test bind-15.31 {MatchPatterns procedure, conflict resolution} { + setup + bind .b.f <M1-Key> {set x 0} + bind .b.f <M2-Key> {set x 1} + set x none + event gen .b.f <Key-a> -state 0x18 + set x +} 1 +test bind-15.32 {MatchPatterns procedure, conflict resolution} { + setup + bind .b.f <M2-Key> {set x 0} + bind .b.f <M1-Key> {set x 1} + set x none + event gen .b.f <Key-a> -state 0x18 + set x +} 1 +test bind-15.33 {MatchPatterns procedure, conflict resolution} { + setup + bind .b.f <1> {lappend x single} + bind Test <1> {lappend x single(Test)} + bind Test <Double-1> {lappend x double(Test)} + set x {} + event gen .b.f <Button-1> + event gen .b.f <Button-1> + event gen .b.f <Button-1> + set x +} {single single(Test) single double(Test) single double(Test)} +foreach i [bind Test] { + bind Test $i {} +} +test bind-16.1 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x abcd} + set x none + event gen .b.f <Enter> + set x +} abcd +test bind-16.2 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x %#} + set x none + event gen .b.f <Enter> -serial 1234 + set x +} 1234 +test bind-16.3 {ExpandPercents procedure} { + setup + bind .b.f <Configure> {set x %a} + set x none + event gen .b.f <Configure> -above .b -window .b.f + set x +} [winfo id .b] +test bind-16.4 {ExpandPercents procedure} { + setup + bind .b.f <Button> {set x %b} + set x none + event gen .b.f <Button-3> + set x +} 3 +test bind-16.5 {ExpandPercents procedure} { + setup + bind .b.f <Expose> {set x %c} + set x none + event gen .b.f <Expose> -count 47 + set x +} 47 +test bind-16.6 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x %d} + set x none + event gen .b.f <Enter> -detail NotifyAncestor + set x +} NotifyAncestor +test bind-16.7 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x %d} + set x none + event gen .b.f <Enter> -detail NotifyVirtual + set x +} NotifyVirtual +test bind-16.8 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x %d} + set x none + event gen .b.f <Enter> -detail NotifyNonlinear + set x +} NotifyNonlinear +test bind-16.9 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x %d} + set x none + event gen .b.f <Enter> -detail NotifyNonlinearVirtual + set x +} NotifyNonlinearVirtual +test bind-16.10 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x %d} + set x none + event gen .b.f <Enter> -detail NotifyPointer + set x +} NotifyPointer +test bind-16.11 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x %d} + set x none + event gen .b.f <Enter> -detail NotifyPointerRoot + set x +} NotifyPointerRoot +test bind-16.12 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x %d} + set x none + event gen .b.f <Enter> -detail NotifyDetailNone + set x +} NotifyDetailNone +test bind-16.13 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x %f} + set x none + event gen .b.f <Enter> -focus 1 + set x +} 1 +test bind-16.14 {ExpandPercents procedure} { + setup + bind .b.f <Expose> {set x "%x %y %w %h"} + set x none + event gen .b.f <Expose> -x 24 -y 18 -width 147 -height 61 + set x +} {24 18 147 61} +test bind-16.15 {ExpandPercents procedure} { + setup + bind .b.f <Configure> {set x "%x %y %w %h"} + set x none + event gen .b.f <Configure> -x 24 -y 18 -width 147 -height 61 -window .b.f + set x +} {24 18 147 61} +test bind-16.16 {ExpandPercents procedure} { + setup + bind .b.f <Key> {set x "%k"} + set x none + event gen .b.f <Key> -keycode 146 + set x +} 146 +test bind-16.17 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x "%m"} + set x none + event gen .b.f <Enter> -mode NotifyNormal + set x +} NotifyNormal +test bind-16.18 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x "%m"} + set x none + event gen .b.f <Enter> -mode NotifyGrab + set x +} NotifyGrab +test bind-16.19 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x "%m"} + set x none + event gen .b.f <Enter> -mode NotifyUngrab + set x +} NotifyUngrab +test bind-16.20 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x "%m"} + set x none + event gen .b.f <Enter> -mode NotifyWhileGrabbed + set x +} NotifyWhileGrabbed +test bind-16.21 {ExpandPercents procedure} { + setup + bind .b.f <Map> {set x "%o"} + set x none + event gen .b.f <Map> -override 1 -window .b.f + set x +} 1 +test bind-16.22 {ExpandPercents procedure} { + setup + bind .b.f <Reparent> {set x "%o"} + set x none + event gen .b.f <Reparent> -override true -window .b.f + set x +} 1 +test bind-16.23 {ExpandPercents procedure} { + setup + bind .b.f <Configure> {set x "%o"} + set x none + event gen .b.f <Configure> -override 1 -window .b.f + set x +} 1 +test bind-16.24 {ExpandPercents procedure} { + setup + bind .b.f <Circulate> {set x "%p"} + set x none + event gen .b.f <Circulate> -place PlaceOnTop -window .b.f + set x +} PlaceOnTop +test bind-16.25 {ExpandPercents procedure} { + setup + bind .b.f <Circulate> {set x "%p"} + set x none + event gen .b.f <Circulate> -place PlaceOnBottom -window .b.f + set x +} PlaceOnBottom +test bind-16.26 {ExpandPercents procedure} { + setup + bind .b.f <1> {set x "%s"} + set x none + event gen .b.f <Button-1> -state 122 + set x +} 122 +test bind-16.27 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x "%s"} + set x none + event gen .b.f <Enter> -state 0x3ff + set x +} 1023 +test bind-16.28 {ExpandPercents procedure} { + setup + bind .b.f <Visibility> {set x "%s"} + set x none + event gen .b.f <Visibility> -state VisibilityPartiallyObscured + set x +} VisibilityPartiallyObscured +test bind-16.29 {ExpandPercents procedure} { + setup + bind .b.f <Visibility> {set x "%s"} + set x none + event gen .b.f <Visibility> -state VisibilityUnobscured + set x +} VisibilityUnobscured +test bind-16.30 {ExpandPercents procedure} { + setup + bind .b.f <Visibility> {set x "%s"} + set x none + event gen .b.f <Visibility> -state VisibilityFullyObscured + set x +} VisibilityFullyObscured +test bind-16.31 {ExpandPercents procedure} { + setup + bind .b.f <Button> {set x "%t"} + set x none + event gen .b.f <Button> -time 4294 + set x +} 4294 +test bind-16.32 {ExpandPercents procedure} { + setup + bind .b.f <Button> {set x "%x %y"} + set x none + event gen .b.f <Button> -x 881 -y 432 + set x +} {881 432} +test bind-16.33 {ExpandPercents procedure} { + setup + bind .b.f <Reparent> {set x "%x %y"} + set x none + event gen .b.f <Reparent> -x 882 -y 431 -window .b.f + set x +} {882 431} +test bind-16.34 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x "%x %y"} + set x none + event gen .b.f <Enter> -x 781 -y 632 + set x +} {781 632} +test bind-16.35 {ExpandPercents procedure} {nonPortable} { + setup + bind .b.f <Key> {lappend x "%A"} + set x {} + event gen .b.f <Key-a> + event gen .b.f <Key-A> -state 1 + event gen .b.f <Key-Tab> + event gen .b.f <Key-Return> + event gen .b.f <Key-F1> + event gen .b.f <Key-Shift_L> + event gen .b.f <Key-space> + event gen .b.f <Key-dollar> -state 1 + event gen .b.f <Key-braceleft> -state 1 + set x +} "a A { } {\r} {{}} {{}} { } {\$} \\\{" +test bind-16.36 {ExpandPercents procedure} { + setup + bind .b.f <Configure> {set x "%B"} + set x none + event gen .b.f <Configure> -borderwidth 24 -window .b.f + set x +} 24 +test bind-16.37 {ExpandPercents procedure} { + setup + bind .b.f <Enter> {set x "%E"} + set x none + event gen .b.f <Enter> -sendevent 1 + set x +} 1 +test bind-16.38 {ExpandPercents procedure} {nonPortable} { + setup + bind .b.f <Key> {lappend x %K} + set x {} + event gen .b.f <Key-a> + event gen .b.f <Key-A> -state 1 + event gen .b.f <Key-Tab> + event gen .b.f <Key-F1> + event gen .b.f <Key-Shift_L> + event gen .b.f <Key-space> + event gen .b.f <Key-dollar> -state 1 + event gen .b.f <Key-braceleft> -state 1 + set x +} {a A Tab F1 Shift_L space dollar braceleft} +test bind-16.39 {ExpandPercents procedure} { + setup + bind .b.f <Key> {set x "%N"} + set x none + event gen .b.f <Key-a> + set x +} 97 +test bind-16.40 {ExpandPercents procedure} { + setup + bind .b.f <Key> {set x "%S"} + set x none + event gen .b.f <Key-a> -subwindow .b + set x +} [winfo id .b] +test bind-16.41 {ExpandPercents procedure} { + setup + bind .b.f <Key> {set x "%T"} + set x none + event gen .b.f <Key> + set x +} 2 +test bind-16.42 {ExpandPercents procedure} { + setup + bind .b.f <Key> {set x "%W"} + set x none + event gen .b.f <Key> + set x +} .b.f +test bind-16.43 {ExpandPercents procedure} { + setup + bind .b.f <Button> {set x "%X %Y"} + set x none + event gen .b.f <Button> -rootx 422 -rooty 13 + set x +} {422 13} + + +test bind-17.1 {event command} { + list [catch {event} msg] $msg +} {1 {wrong # args: should be "event option ?arg1?"}} +test bind-17.2 {event command} { + list [catch {event {}} msg] $msg +} {1 {bad option "": should be add, delete, generate, info}} +test bind-17.3 {event command: add} { + list [catch {event add} msg] $msg +} {1 {wrong # args: should be "event add virtual sequence ?sequence ...?"}} +test bind-17.4 {event command: add 1} { + setup + event add <<Paste>> <Control-v> + event info <<Paste>> +} {<Control-Key-v>} +test bind-17.5 {event command: add 2} { + setup + event add <<Paste>> <Control-v> <Button-2> + lsort [event info <<Paste>>] +} {<Button-2> <Control-Key-v>} +test bind-17.6 {event command: add with error} { + setup + list [catch {event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1>} \ + msg] $msg [lsort [event info <<Paste>>]] +} {1 {bad event type or keysym "xyz"} {<Button-2> <Control-Key-v> abc}} +test bind-17.7 {event command: delete} { + list [catch {event delete} msg] $msg +} {1 {wrong # args: should be "event delete virtual ?sequence sequence ...?"}} +test bind-17.8 {event command: delete many} { + setup + event add <<Paste>> <3> <1> <2> t + event delete <<Paste>> <1> <2> + lsort [event info <<Paste>>] +} {<Button-3> t} +test bind-17.9 {event command: delete all} { + setup + event add <<Paste>> a b + event delete <<Paste>> + event info <<Paste>> +} {} +test bind-17.10 {event command: delete 1} { + setup + event add <<Paste>> a b c + event delete <<Paste>> b + lsort [event info <<Paste>>] +} {a c} +test bind-17.11 {event command: info name} { + setup + event add <<Paste>> a b c + lsort [event info <<Paste>>] +} {a b c} +test bind-17.12 {event command: info all} { + setup + event add <<Paste>> a + event add <<Alive>> b + lsort [event info] +} {<<Alive>> <<Paste>>} +test bind-17.13 {event command: info error} { + list [catch {event info <<Paste>> <Control-v>} msg] $msg +} {1 {wrong # args: should be "event info ?virtual?"}} +test bind-17.14 {event command: generate} { + list [catch {event generate} msg] $msg +} {1 {wrong # args: should be "event generate window event ?options?"}} +test bind-17.15 {event command: generate} { + setup + bind .b.f <1> "lappend x 1" + set x {} + event generate .b.f <1> + set x +} {1} +test bind-17.16 {event command: generate} { + list [catch {event generate .b.f <xyz>} msg] $msg +} {1 {bad event type or keysym "xyz"}} +test bind-17.17 {event command} { + list [catch {event foo} msg] $msg +} {1 {bad option "foo": should be add, delete, generate, info}} + + +test bind-18.1 {CreateVirtualEvent procedure: GetVirtualEventUid} { + list [catch {event add asd <Ctrl-v>} msg] $msg +} {1 {virtual event "asd" is badly formed}} +test bind-18.2 {CreateVirtualEvent procedure: FindSequence} { + list [catch {event add <<asd>> <Ctrl-v>} msg] $msg +} {1 {bad event type or keysym "Ctrl"}} +test bind-18.3 {CreateVirtualEvent procedure: new physical} { + setup + event add <<xyz>> <Control-v> + event info <<xyz>> +} {<Control-Key-v>} +test bind-18.4 {CreateVirtualEvent procedure: duplicate physical} { + setup + event add <<xyz>> <Control-v> + event add <<xyz>> <Control-v> + event info <<xyz>> +} {<Control-Key-v>} +test bind-18.5 {CreateVirtualEvent procedure: existing physical} { + setup + event add <<xyz>> <Control-v> + event add <<abc>> <Control-v> + list [lsort [event info]] [event info <<xyz>>] [event info <<abc>>] +} {{<<abc>> <<xyz>>} <Control-Key-v> <Control-Key-v>} +test bind-18.6 {CreateVirtualEvent procedure: new virtual} { + setup + event add <<xyz>> <Control-v> + list [event info] [event info <<xyz>>] +} {<<xyz>> <Control-Key-v>} +test bind-18.7 {CreateVirtualEvent procedure: existing virtual} { + setup + event add <<xyz>> <Control-v> + event add <<xyz>> <Button-2> + list [event info] [lsort [event info <<xyz>>]] +} {<<xyz>> {<Button-2> <Control-Key-v>}} + + +test bind-19.1 {DeleteVirtualEvent procedure: GetVirtualEventUid} { + list [catch {event add xyz {}} msg] $msg +} {1 {virtual event "xyz" is badly formed}} +test bind-19.2 {DeleteVirtualEvent procedure: non-existent virtual} { + setup + event delete <<xyz>> + event info +} {} +test bind-19.3 {DeleteVirtualEvent procedure: delete 1} { + setup + event add <<xyz>> <Control-v> + event delete <<xyz>> <Control-v> + event info <<xyz>> +} {} +test bind-19.4 {DeleteVirtualEvent procedure: delete 1, not owned} { + setup + event add <<xyz>> <Control-v> + event delete <<xyz>> <Button-1> + event info <<xyz>> +} {<Control-Key-v>} +test bind-19.5 {DeleteVirtualEvent procedure: delete 1, badly formed} { + setup + event add <<xyz>> <Control-v> + list [catch {event delete <<xyz>> <xyz>} msg] $msg +} {1 {bad event type or keysym "xyz"}} +test bind-19.6 {DeleteVirtualEvent procedure: delete 1, badly formed} { + setup + event add <<xyz>> <Control-v> + list [catch {event delete <<xyz>> <<Paste>>} msg] $msg +} {1 {virtual event not allowed in definition of another virtual event}} +test bind-19.7 {DeleteVirtualEvent procedure: owns 1, delete all} { + setup + event add <<xyz>> <Control-v> + event delete <<xyz>> + event info +} {} +test bind-19.8 {DeleteVirtualEvent procedure: owns 1, delete 1} { + setup + event add <<xyz>> <Control-v> + event delete <<xyz>> <Control-v> + event info +} {} +test bind-19.9 {DeleteVirtualEvent procedure: owns many, delete all} { + setup + event add <<xyz>> <Control-v> <Control-w> <Control-x> + event delete <<xyz>> + event info +} {} +test bind-19.10 {DeleteVirtualEvent procedure: owns many, delete 1} { + setup + event add <<xyz>> <Control-v> <Control-w> <Control-x> + event delete <<xyz>> <Control-w> + lsort [event info <<xyz>>] +} {<Control-Key-v> <Control-Key-x>} +test bind-19.11 {DeleteVirtualEvent procedure: owned by 1, only} { + setup + event add <<xyz>> <Button-2> + bind .b.f <<xyz>> {lappend x %#} + set x {} + event gen .b.f <Button-2> -serial 101 + event delete <<xyz>> + event gen .b.f <Button-2> -serial 102 + set x +} {101} +test bind-19.12 {DeleteVirtualEvent procedure: owned by 1, first in chain} { + setup + event add <<abc>> <Control-Button-2> + event add <<xyz>> <Button-2> + bind .b.f <<xyz>> {lappend x xyz} + bind .b.f <<abc>> {lappend x abc} + set x {} + event gen .b.f <Button-2> + event gen .b.f <Control-Button-2> + event delete <<xyz>> + event gen .b.f <Button-2> + event gen .b.f <Control-Button-2> + list $x [event info <<abc>>] +} {{xyz abc abc} <Control-Button-2>} +test bind-19.13 {DeleteVirtualEvent procedure: owned by 1, second in chain} { + setup + event add <<def>> <Shift-Button-2> + event add <<xyz>> <Button-2> + event add <<abc>> <Control-Button-2> + bind .b.f <<xyz>> {lappend x xyz} + bind .b.f <<abc>> {lappend x abc} + bind .b.f <<def>> {lappend x def} + set x {} + event gen .b.f <Button-2> + event gen .b.f <Control-Button-2> + event gen .b.f <Shift-Button-2> + event delete <<xyz>> + event gen .b.f <Button-2> + event gen .b.f <Control-Button-2> + event gen .b.f <Shift-Button-2> + list $x [event info <<def>>] [event info <<xyz>>] [event info <<abc>>] +} {{xyz abc def abc def} <Shift-Button-2> {} <Control-Button-2>} +test bind-19.14 {DeleteVirtualEvent procedure: owned by 1, last in chain} { + setup + event add <<xyz>> <Button-2> + event add <<abc>> <Control-Button-2> + event add <<def>> <Shift-Button-2> + bind .b.f <<xyz>> {lappend x xyz} + bind .b.f <<abc>> {lappend x abc} + bind .b.f <<def>> {lappend x def} + set x {} + event gen .b.f <Button-2> + event gen .b.f <Control-Button-2> + event gen .b.f <Shift-Button-2> + event delete <<xyz>> + event gen .b.f <Button-2> + event gen .b.f <Control-Button-2> + event gen .b.f <Shift-Button-2> + list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] +} {{xyz abc def abc def} {} <Control-Button-2> <Shift-Button-2>} +test bind-19.15 {DeleteVirtualEvent procedure: owned by many, first} { + setup + pack [frame .b.g -class Test -width 150 -height 100] + pack [frame .b.h -class Test -width 150 -height 100] + update + event add <<xyz>> <Button-2> + event add <<abc>> <Button-2> + event add <<def>> <Button-2> + bind .b.f <<xyz>> {lappend x xyz} + bind .b.g <<abc>> {lappend x abc} + bind .b.h <<def>> {lappend x def} + set x {} + event gen .b.f <Button-2> + event gen .b.g <Button-2> + event gen .b.h <Button-2> + event delete <<xyz>> + event gen .b.f <Button-2> + event gen .b.g <Button-2> + event gen .b.h <Button-2> + destroy .b.g + destroy .b.h + list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] +} {{xyz abc def abc def} {} <Button-2> <Button-2>} +test bind-19.16 {DeleteVirtualEvent procedure: owned by many, middle} { + setup + pack [frame .b.g -class Test -width 150 -height 100] + pack [frame .b.h -class Test -width 150 -height 100] + update + event add <<xyz>> <Button-2> + event add <<abc>> <Button-2> + event add <<def>> <Button-2> + bind .b.f <<xyz>> {lappend x xyz} + bind .b.g <<abc>> {lappend x abc} + bind .b.h <<def>> {lappend x def} + set x {} + event gen .b.f <Button-2> + event gen .b.g <Button-2> + event gen .b.h <Button-2> + event delete <<abc>> + event gen .b.f <Button-2> + event gen .b.g <Button-2> + event gen .b.h <Button-2> + destroy .b.g + destroy .b.h + list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] +} {{xyz abc def xyz def} <Button-2> {} <Button-2>} +test bind-19.17 {DeleteVirtualEvent procedure: owned by many, last} { + setup + pack [frame .b.g -class Test -width 150 -height 100] + pack [frame .b.h -class Test -width 150 -height 100] + update + event add <<xyz>> <Button-2> + event add <<abc>> <Button-2> + event add <<def>> <Button-2> + bind .b.f <<xyz>> {lappend x xyz} + bind .b.g <<abc>> {lappend x abc} + bind .b.h <<def>> {lappend x def} + set x {} + event gen .b.f <Button-2> + event gen .b.g <Button-2> + event gen .b.h <Button-2> + event delete <<def>> + event gen .b.f <Button-2> + event gen .b.g <Button-2> + event gen .b.h <Button-2> + destroy .b.g + destroy .b.h + list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] +} {{xyz abc def xyz abc} <Button-2> <Button-2> {}} + + +test bind-20.1 {GetVirtualEvent procedure: GetVirtualEventUid} { + list [catch {event info asd} msg] $msg +} {1 {virtual event "asd" is badly formed}} +test bind-20.2 {GetVirtualEvent procedure: non-existent event} { + event info <<asd>> +} {} +test bind-20.3 {GetVirtualEvent procedure: owns 1} { + setup + event add <<xyz>> <Control-Key-v> + event info <<xyz>> +} {<Control-Key-v>} +test bind-20.4 {GetVirtualEvent procedure: owns many} { + setup + event add <<xyz>> <Control-v> <Button-2> spack + event info <<xyz>> +} {<Control-Key-v> <Button-2> spack} + + +test bind-21.1 {GetAllVirtualEvents procedure: no events} { + setup + event info +} {} +test bind-21.2 {GetAllVirtualEvents procedure: 1 event} { + setup + event add <<xyz>> <Control-v> + event info +} {<<xyz>>} +test bind-21.3 {GetAllVirtualEvents procedure: many events} { + setup + event add <<xyz>> <Control-v> + event add <<xyz>> <Button-2> + event add <<abc>> <Control-v> + event add <<def>> <Key-F6> + lsort [event info] +} {<<abc>> <<def>> <<xyz>>} + +test bind-22.1 {HandleEventGenerate} { + list [catch {event gen .xyz <Control-v>} msg] $msg +} {1 {bad window path name ".xyz"}} +test bind-22.2 {HandleEventGenerate} { + list [catch {event gen zzz <Control-v>} msg] $msg +} {1 {bad window name/identifier "zzz"}} +test bind-22.3 {HandleEventGenerate} { + list [catch {event gen 47 <Control-v>} msg] $msg +} {1 {window id "47" doesn't exist in this application}} +test bind-22.4 {HandleEventGenerate} { + setup + bind .b.f <Button> {set x "%s %b"} + set x {} + event gen [winfo id .b.f] <Control-Button-1> + set x +} {4 1} +test bind-22.5 {HandleEventGenerate} { + list [catch {event gen . <xyz>} msg] $msg +} {1 {bad event type or keysym "xyz"}} +test bind-22.6 {HandleEventGenerate} { + list [catch {event gen . <Double-Button-1>} msg] $msg +} {1 {Double or Triple modifier not allowed}} +test bind-22.7 {HandleEventGenerate} { + list [catch {event gen . xyz} msg] $msg +} {1 {only one event specification allowed}} +test bind-22.8 {HandleEventGenerate} { + list [catch {event gen . <Button> -button} msg] $msg +} {1 {value for "-button" missing}} +test bind-22.9 {HandleEventGenerate} { + setup + bind .b.f <Button> {set x "%s %b"} + set x {} + event gen .b.f <Control-Button-1> + set x +} {4 1} +test bind-22.10 {HandleEventGenerate} { + setup + bind .b.f <Key> {set x "%s %K"} + set x {} + event gen .b.f <Control-Key-1> + set x +} {4 1} +test bind-22.11 {HandleEventGenerate} { + setup + bind .b.f <<Paste>> {set x "%s"} + set x {} + event gen .b.f <<Paste>> -state 1 + set x +} {1} +test bind-22.12 {HandleEventGenerate} { + setup + bind .b.f <Motion> {set x "%s"} + set x {} + event gen .b.f <Control-Motion> + set x +} {4} +test bind-22.13 {HandleEventGenerate} { + setup + bind .b.f <Button> {lappend x %#} + set x {} + event gen .b.f <Button> -when now -serial 100 + set x +} {100} +test bind-22.14 {HandleEventGenerate} { + setup + bind .b.f <Button> {lappend x %#} + set x {} + event gen .b.f <Button> -when head -serial 100 + event gen .b.f <Button> -when head -serial 101 + event gen .b.f <Button> -when head -serial 102 + lappend x foo + update + set x +} {foo 102 101 100} +test bind-22.15 {HandleEventGenerate} { + setup + bind .b.f <Button> {lappend x %#} + set x {} + event gen .b.f <Button> -when head -serial 99 + event gen .b.f <Button> -when mark -serial 100 + event gen .b.f <Button> -when mark -serial 101 + event gen .b.f <Button> -when mark -serial 102 + lappend x foo + update + set x +} {foo 100 101 102 99} +test bind-22.16 {HandleEventGenerate} { + setup + bind .b.f <Button> {lappend x %#} + set x {} + event gen .b.f <Button> -when head -serial 99 + event gen .b.f <Button> -when tail -serial 100 + event gen .b.f <Button> -when tail -serial 101 + event gen .b.f <Button> -when tail -serial 102 + lappend x foo + update + set x +} {foo 99 100 101 102} +test bind-22.17 {HandleEventGenerate} { + list [catch {event gen . <Button> -when xyz} msg] $msg +} {1 {bad position "xyz": should be now, head, mark, tail}} +set i 14 +foreach check { + {<Configure> %a {-above .xyz} {{1 {bad window path name ".xyz"}}}} + {<Configure> %a {-above .b} {[winfo id .b]}} + {<Configure> %a {-above xyz} {{1 {expected integer but got "xyz"}}}} + {<Configure> %a {-above [winfo id .b]} {[winfo id .b]}} + {<Key> %b {-above .} {{1 {bad option to <Key> event: "-above"}}}} + + {<Configure> %B {-borderwidth xyz} {{1 {bad screen distance "xyz"}}}} + {<Configure> %B {-borderwidth 2i} {[winfo pixels .b.f 2i]}} + {<Key> %k {-borderwidth 2i} {{1 {bad option to <Key> event: "-borderwidth"}}}} + + {<Button> %b {-button xyz} {{1 {expected integer but got "xyz"}}}} + {<Button> %b {-button 1} 1} + {<Key> %k {-button 1} {{1 {bad option to <Key> event: "-button"}}}} + + {<Expose> %c {-count xyz} {{1 {expected integer but got "xyz"}}}} + {<Expose> %c {-count 20} 20} + {<Key> %b {-count 20} {{1 {bad option to <Key> event: "-count"}}}} + + {<Enter> %d {-detail xyz} {{1 {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, NotifyDetailNone}}}} + {<FocusIn> %d {-detail NotifyVirtual} {{}}} + {<Enter> %d {-detail NotifyVirtual} NotifyVirtual} + {<Key> %k {-detail NotifyVirtual} {{1 {bad option to <Key> event: "-detail"}}}} + + {<Enter> %f {-focus xyz} {{1 {expected boolean value but got "xyz"}}}} + {<Enter> %f {-focus 1} 1} + {<Key> %k {-focus 1} {{1 {bad option to <Key> event: "-focus"}}}} + + {<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 {bad option to <Key> event: "-height"}}}} + + {<Key> %k {-keycode xyz} {{1 {expected integer but got "xyz"}}}} + {<Key> %k {-keycode 20} 20} + {<Button> %b {-keycode 20} {{1 {bad option to <Button> event: "-keycode"}}}} + + {<Key> %K {-keysym xyz} {{1 {unknown keysym "xyz"}}}} + {<Key> %K {-keysym a} a} + {<Button> %b {-keysym a} {{1 {bad option to <Button> event: "-keysym"}}}} + + {<Enter> %m {-mode xyz} {{1 {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, NotifyWhileGrabbed}}}} + {<Enter> %m {-mode NotifyNormal} NotifyNormal} + {<FocusIn> %m {-mode NotifyNormal} {{}}} + {<Key> %k {-mode NotifyNormal} {{1 {bad option to <Key> event: "-mode"}}}} + + {<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 {bad option to <Key> event: "-override"}}}} + + {<Circulate> %p {-place xyz} {{1 {bad -place value "xyz": must be PlaceOnTop, PlaceOnBottom}}}} + {<Circulate> %p {-place PlaceOnTop} PlaceOnTop} + {<Key> %k {-place PlaceOnTop} {{1 {bad option to <Key> event: "-place"}}}} + + {<Key> %R {-root .xyz} {{1 {bad window path name ".xyz"}}}} + {<Key> %R {-root .b} {[winfo id .b]}} + {<Key> %R {-root xyz} {{1 {expected integer but got "xyz"}}}} + {<Key> %R {-root [winfo id .b]} {[winfo id .b]}} + {<Button> %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 {bad option to <Configure> event: "-root"}}}} + + {<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]}} + {<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 {bad option to <Configure> event: "-rootx"}}}} + + {<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]}} + {<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 {bad option to <Configure> event: "-rooty"}}}} + + {<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 1} 1} + {<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, VisibilityFullyObscured}}}} + {<Visibility> %s {-state VisibilityUnobscured} VisibilityUnobscured} + {<Configure> %s {-state xyz} {{1 {bad option to <Configure> event: "-state"}}}} + + {<Key> %S {-subwindow .xyz} {{1 {bad window path name ".xyz"}}}} + {<Key> %S {-subwindow .b} {[winfo id .b]}} + {<Key> %S {-subwindow xyz} {{1 {expected integer but got "xyz"}}}} + {<Key> %S {-subwindow [winfo id .b]} {[winfo id .b]}} + {<Button> %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 {bad option to <Configure> event: "-subwindow"}}}} + + {<Key> %t {-time xyz} {{1 {expected integer but got "xyz"}}}} + {<Key> %t {-time 100} 100} + {<Button> %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 {bad option to <Configure> event: "-time"}}}} + + {<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 {bad option to <Key> event: "-width"}}}} + + {<Unmap> %W {-window .xyz} {{1 {bad window path name ".xyz"}}}} + {<Unmap> %W {-window .b.f} .b.f} + {<Unmap> %W {-window xyz} {{1 {expected integer but got "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 {bad option to <Key> event: "-window"}}}} + + {<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]}} + {<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 {bad option to <Map> event: "-x"}}}} + + {<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]}} + {<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 {bad option to <Map> event: "-y"}}}} + + {<Key> %k {-xyz 1} {{1 {bad option to <Key> event: "-xyz"}}}} +} { + set event [lindex $check 0] + test bind-22.$i "HandleEventGenerate: options $event [lindex $check 2]" { + setup + bind .b.f $event "lappend x [lindex $check 1]" + set x {} + if [catch {eval event gen .b.f $event [lindex $check 2]} msg] { + set x [list 1 $msg] + } + set x + } [eval set x [lindex $check 3]] + incr i +} +test bind-23.1 {GetVirtualEventUid procedure} { + list [catch {event info <<asd} msg] $msg +} {1 {virtual event "<<asd" is badly formed}} +test bind-23.2 {GetVirtualEventUid procedure} { + list [catch {event info <<>>} msg] $msg +} {1 {virtual event "<<>>" is badly formed}} +test bind-23.3 {GetVirtualEventUid procedure} { + list [catch {event info <<asd>} msg] $msg +} {1 {virtual event "<<asd>" is badly formed}} +test bind-23.4 {GetVirtualEventUid procedure} { + event info <<asd>> +} {} + + +test bind-24.1 {FindSequence procedure: no event} { + list [catch {bind .b {} test} msg] $msg +} {1 {no events specified in binding}} +test bind-24.2 {FindSequence procedure: bad event} { + list [catch {bind .b <xyz> test} msg] $msg +} {1 {bad event type or keysym "xyz"}} +test bind-24.3 {FindSequence procedure: virtual allowed} { + bind .b.f <<Paste>> test +} {} +test bind-24.4 {FindSequence procedure: virtual not allowed} { + list [catch {event add <<Paste>> <<Alive>>} msg] $msg +} {1 {virtual event not allowed in definition of another virtual event}} +test bind-24.5 {FindSequence procedure, multiple bindings} { + setup + bind .b.f <1> {lappend x single} + bind .b.f <Double-1> {lappend x double} + bind .b.f <Triple-1> {lappend x triple} + set x press + event gen .b.f <Button-1> + lappend x press + event gen .b.f <Button-1> + lappend x press + event gen .b.f <Button-1> + lappend x press + event gen .b.f <Button-1> + set x +} {press single press double press triple press triple} +test bind-24.6 {FindSequence procedure: virtual composed} { + list [catch {bind .b <Control-b><<Paste>> "puts hi"} msg] $msg +} {1 {virtual events may not be composed}} +test bind-24.7 {FindSequence procedure: new pattern sequence} { + setup + bind .b.f <Button-1><Button-2> {lappend x 1-2} + set x {} + event gen .b.f <Button-1> + event gen .b.f <Button-2> + set x +} {1-2} +test bind-24.8 {FindSequence procedure: similar pattern sequence} { + setup + bind .b.f <Button-1><Button-2> {lappend x 1-2} + bind .b.f <Button-2> {lappend x 2} + set x {} + event gen .b.f <Button-3> + event gen .b.f <Button-2> + event gen .b.f <Button-1> + event gen .b.f <Button-2> + set x +} {2 1-2} +test bind-24.9 {FindSequence procedure: similar pattern sequence} { + setup + bind .b.f <Button-1><Button-2> {lappend x 1-2} + bind .b.f <Button-2><Button-2> {lappend x 2-2} + set x {} + event gen .b.f <Button-3> + event gen .b.f <Button-2> + event gen .b.f <Button-2> + event gen .b.f <Button-1> + event gen .b.f <Button-2> + set x +} {2-2 1-2} +test bind-24.10 {FindSequence procedure: similar pattern sequence} { + setup + bind .b.f <Button-2><Button-2> {lappend x 2-2} + bind .b.f <Double-Button-2> {lappend x d-2} + set x {} + event gen .b.f <Button-3> + event gen .b.f <Button-2> + event gen .b.f <Button-2> + event gen .b.f <Button-1> + event gen .b.f <Button-2> -x 100 + event gen .b.f <Button-2> -x 200 + set x +} {d-2 2-2} +test bind-24.11 {FindSequence procedure: new sequence, don't create} { + setup + bind .b.f <Button-2> +} {} +test bind-24.12 {FindSequence procedure: not new sequence, don't create} { + setup + bind .b.f <Control-Button-2> "foo" + bind .b.f <Button-2> +} {} + + +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} { + setup + 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} { + button .x + bind .x <Control-M> a + bind .x <M-M> b + set x [lsort [bind .x]] + destroy .x + set x +} {<Control-Key-M> <Meta-Key-M>} +test bind-25.11 {ParseEventDescription procedure} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + 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} { + setup + 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>} +} { + test bind-25.$i {modifier names} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + bind .b.f [lindex $check 0] foo + bind .b.f + } [lindex $check 1] + bind .b.f [lindex $check 1] {} + incr i +} + +foreach event [bind Test] { + bind Test $event {} +} +foreach event [bind all] { + bind all $event {} +} +test bind-26.1 {event names} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + bind .b.f <FocusIn> {nothing} + bind .b.f +} <FocusIn> +test bind-26.2 {event names} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + bind .b.f <FocusOut> {nothing} + bind .b.f +} <FocusOut> +test bind-26.3 {event names} { + setup + bind .b.f <Destroy> {lappend x "destroyed"} + set x [bind .b.f] + 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} +} { + set event [lindex $check 0] + test bind-26.$i {event names} { + 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 +} +foreach check { + {Circulate Circulate} + {Configure Configure} + {Gravity Gravity} + {Map Map} + {Reparent Reparent} + {Unmap Unmap} +} { + set event [lindex $check 0] + test bind-26.$i {event names} { + 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 +} + + +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> + set x + } [list <Button-$button> "button $button"] + incr i +} + +test bind-28.1 {keysym names} { + list [catch {bind .b <Expose-a> foo} msg] $msg +} {1 {specified keysym "a" for non-key event}} +test bind-28.2 {keysym names} { + list [catch {bind .b <Gorp> foo} msg] $msg +} {1 {bad event type or keysym "Gorp"}} +test bind-28.3 {keysym names} { + list [catch {bind .b <Key-Stupid> foo} msg] $msg +} {1 {bad event type or keysym "Stupid"}} +test bind-28.4 {keysym names} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + 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} +} { + set keysym [lindex $check 0] + test bind-28.$i {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] + set x + } [concat [lsort "x [lindex $check 2]"] "{keysym $keysym}"] + incr i +} + +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} +} { + test bind-29.$i {GetKeySym procedure} {nonPortable} { + set x nothing + event gen .b.f <KeyPress> -keysym [lindex $check 0] \ + -state [lindex $check 1] + set x + } [lindex $check 2] + incr i +} + + +proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] +} +test bind-30.1 {Tk_BackgroundError procedure} { + setup + bind .b.f <Button> {error "This is a test"} + set x none + event gen .b.f <Button> + update + set x +} {{This is a test} {This is a test + while executing +"error "This is a test"" + (command bound to event)}} +test bind-30.2 {Tk_BackgroundError procedure} { + proc do {} { + event gen .b.f <Button> + } + setup + bind .b.f <Button> {error Message2} + set x none + do + update + set x +} {Message2 {Message2 + while executing +"error Message2" + (command bound to event)}} +rename bgerror {} + + +destroy .b diff --git a/tests/bugs.tcl b/tests/bugs.tcl new file mode 100644 index 0000000..1f4e5b7 --- /dev/null +++ b/tests/bugs.tcl @@ -0,0 +1,30 @@ +# This file is a Tcl script to test out various known bugs that will +# cause Tk to crash. This file ends with .tcl instead of .test to make +# sure it isn't run when you type "source all". We currently are not +# shipping this file with the rest of the source release. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) bugs.tcl 1.1 96/07/25 15:49:45 + +if {[info procs test] != "test"} { + source defs +} + +test crash-1.0 {imgPhoto} { + image create photo p1 + image create photo p2 + catch {image create photo p2 -file bogus} + p1 copy p2 + label .l -image p1 + destroy .l + set foo "" +} {} + +test crash-1.1 {color} { + . configure -bg rgb:345 + set foo "" +} {} diff --git a/tests/butGeom.tcl b/tests/butGeom.tcl new file mode 100644 index 0000000..352712b --- /dev/null +++ b/tests/butGeom.tcl @@ -0,0 +1,115 @@ +# This file creates a visual test for button layout. It is part of +# the Tk visual test suite, which is invoked via the "visual" script. +# +# SCCS: @(#) butGeom.tcl 1.3 97/06/13 13:46:57 + +catch {destroy .t} +toplevel .t +wm title .t "Visual Tests for Button Geometry" +wm iconname .t "Button Geometry" +wm geom .t +0+0 +wm minsize .t 1 1 + +label .t.l -text {This screen exercises the layout mechanisms for various flavors of buttons. Select display options below, and they will be applied to all of the button widgets. In order to see the effects of different anchor positions, expand the window so that there is extra space in the buttons. The letter "o" in "automatically" should be underlined in the right column of widgets.} -wraplength 5i +pack .t.l -side top -fill both + +button .t.quit -text Quit -command {destroy .t} +pack .t.quit -side bottom -pady 2m + +set sepId 1 +proc sep {} { + global sepId + frame .t.sep$sepId -height 2 -bd 1 -relief sunken + pack .t.sep$sepId -side top -padx 2m -pady 2m -fill x + incr sepId +} + +# Create buttons that control configuration options. + +frame .t.control +pack .t.control -side top -fill x -pady 3m +frame .t.control.left +frame .t.control.right +pack .t.control.left .t.control.right -side left -expand 1 -fill x +label .t.anchorLabel -text "Anchor:" +frame .t.control.left.f -width 6c -height 3c +pack .t.anchorLabel .t.control.left.f -in .t.control.left -side top +foreach anchor {nw n ne w center e sw s se} { + button .t.anchor-$anchor -text $anchor -command "config -anchor $anchor" +} +place .t.anchor-nw -in .t.control.left.f -relx 0 -relwidth 0.333 \ + -rely 0 -relheight 0.333 +place .t.anchor-n -in .t.control.left.f -relx 0.333 -relwidth 0.333 \ + -rely 0 -relheight 0.333 +place .t.anchor-ne -in .t.control.left.f -relx 0.666 -relwidth 0.333 \ + -rely 0 -relheight 0.333 +place .t.anchor-w -in .t.control.left.f -relx 0 -relwidth 0.333 \ + -rely 0.333 -relheight 0.333 +place .t.anchor-center -in .t.control.left.f -relx 0.333 -relwidth 0.333 \ + -rely 0.333 -relheight 0.333 +place .t.anchor-e -in .t.control.left.f -relx 0.666 -relwidth 0.333 \ + -rely 0.333 -relheight 0.333 +place .t.anchor-sw -in .t.control.left.f -relx 0 -relwidth 0.333 \ + -rely 0.666 -relheight 0.333 +place .t.anchor-s -in .t.control.left.f -relx 0.333 -relwidth 0.333 \ + -rely 0.666 -relheight 0.333 +place .t.anchor-se -in .t.control.left.f -relx 0.666 -relwidth 0.333 \ + -rely 0.666 -relheight 0.333 + +set justify center +radiobutton .t.justify-left -text "Justify Left" -relief flat \ + -command "config -justify left" -variable justify \ + -value left +radiobutton .t.justify-center -text "Justify Center" -relief flat \ + -command "config -justify center" -variable justify \ + -value center +radiobutton .t.justify-right -text "Justify Right" -relief flat \ + -command "config -justify right" -variable justify \ + -value right +pack .t.justify-left .t.justify-center .t.justify-right \ + -in .t.control.right -anchor w + +sep +frame .t.f1 +pack .t.f1 -side top -expand 1 -fill both +sep +frame .t.f2 +pack .t.f2 -side top -expand 1 -fill both +sep +frame .t.f3 +pack .t.f3 -side top -expand 1 -fill both +sep +frame .t.f4 +pack .t.f4 -side top -expand 1 -fill both +sep + +label .t.l1 -text Label -bd 2 -relief sunken +label .t.l2 -text "Explicit\nnewlines\n\nin the text" -bd 2 -relief sunken +label .t.l3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -bd 2 -relief sunken -underline 50 +pack .t.l1 .t.l2 .t.l3 -in .t.f1 -side left -padx 5m -pady 3m \ + -expand y -fill both + +button .t.b1 -text Button +button .t.b2 -text "Explicit\nnewlines\n\nin the text" +button .t.b3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -underline 50 +pack .t.b1 .t.b2 .t.b3 -in .t.f2 -side left -padx 5m -pady 3m \ + -expand y -fill both + +checkbutton .t.c1 -text Checkbutton -variable a +checkbutton .t.c2 -text "Explicit\nnewlines\n\nin the text" -variable b +checkbutton .t.c3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -variable c -underline 50 +pack .t.c1 .t.c2 .t.c3 -in .t.f3 -side left -padx 5m -pady 3m \ + -expand y -fill both + +radiobutton .t.r1 -text Radiobutton -value a +radiobutton .t.r2 -text "Explicit\nnewlines\n\nin the text" -value b +radiobutton .t.r3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -value c -underline 50 +pack .t.r1 .t.r2 .t.r3 -in .t.f4 -side left -padx 5m -pady 3m \ + -expand y -fill both + +proc config {option value} { + foreach w {.t.l1 .t.l2 .t.l3 .t.b1 .t.b2 .t.b3 .t.c1 .t.c2 .t.c3 + .t.r1 .t.r2 .t.r3} { + $w configure $option $value + } +} diff --git a/tests/butGeom2.tcl b/tests/butGeom2.tcl new file mode 100644 index 0000000..f1293a0 --- /dev/null +++ b/tests/butGeom2.tcl @@ -0,0 +1,113 @@ +# This file creates a visual test for button layout. It is part of +# the Tk visual test suite, which is invoked via the "visual" script. +# +# SCCS: @(#) butGeom2.tcl 1.3 97/06/13 17:00:32 + +catch {destroy .t} +toplevel .t +wm title .t "Visual Tests for Button Geometry" +wm iconname .t "Button Geometry" +wm geom .t +0+0 +wm minsize .t 1 1 + +label .t.l -text {This screen exercises the color options for various flavors of buttons. Select display options below, and they will be applied to the appropiate button widgets.} -wraplength 5i +pack .t.l -side top -fill both + +button .t.quit -text Quit -command {destroy .t} +pack .t.quit -side bottom -pady 2m + +set sepId 1 +proc sep {} { + global sepId + frame .t.sep$sepId -height 2 -bd 1 -relief sunken + pack .t.sep$sepId -side top -padx 2m -pady 2m -fill x + incr sepId +} + +# Create buttons that control configuration options. + +frame .t.control +pack .t.control -side top -fill x -pady 3m +frame .t.control.left +frame .t.control.right +pack .t.control.left .t.control.right -side left -expand 1 -fill x +label .t.anchorLabel -text "Color:" +frame .t.control.left.f -width 6c -height 3c +pack .t.anchorLabel .t.control.left.f -in .t.control.left -side top -anchor w +foreach opt {activebackground activeforeground background disabledforeground foreground highlightbackground highlightcolor } { + #button .t.color-$opt -text $opt -command "config -$opt \[tk_chooseColor]" + menubutton .t.color-$opt -text $opt -menu .t.color-$opt.m -indicatoron 1 \ + -relief raised -bd 2 + menu .t.color-$opt.m -tearoff 0 + .t.color-$opt.m add command -label Red -command "config -$opt red" + .t.color-$opt.m add command -label Green -command "config -$opt green" + .t.color-$opt.m add command -label Blue -command "config -$opt blue" + .t.color-$opt.m add command -label Other... \ + -command "config -$opt \[tk_chooseColor]" + pack .t.color-$opt -in .t.control.left.f -fill x +} + +set default disabled +label .t.default -text Default: +radiobutton .t.default-normal -text "Default normal" -relief flat \ + -command "config-but -default normal" -variable default \ + -value normal +radiobutton .t.default-active -text "Default active" -relief flat \ + -command "config-but -default active" -variable default \ + -value active +radiobutton .t.default-disabled -text "Default disabled" -relief flat \ + -command "config-but -default disabled" -variable default \ + -value disabled +pack .t.default .t.default-normal .t.default-active .t.default-disabled \ + -in .t.control.right -anchor w + +sep +frame .t.f1 +pack .t.f1 -side top -expand 1 -fill both +sep +frame .t.f2 +pack .t.f2 -side top -expand 1 -fill both +sep +frame .t.f3 +pack .t.f3 -side top -expand 1 -fill both +sep +frame .t.f4 +pack .t.f4 -side top -expand 1 -fill both +sep + +label .t.l1 -text Label -bd 2 -relief sunken +label .t.l2 -text "Explicit\nnewlines\n\nin the text" -bd 2 -relief sunken +label .t.l3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -bd 2 -relief sunken -underline 50 +pack .t.l1 .t.l2 .t.l3 -in .t.f1 -side left -padx 5m -pady 3m \ + -expand y -fill both + +button .t.b1 -text Button +button .t.b2 -text "Explicit\nnewlines\n\nin the text" +button .t.b3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -underline 50 +pack .t.b1 .t.b2 .t.b3 -in .t.f2 -side left -padx 5m -pady 3m \ + -expand y -fill both + +checkbutton .t.c1 -text Checkbutton -variable a +checkbutton .t.c2 -text "Explicit\nnewlines\n\nin the text" -variable b +checkbutton .t.c3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -variable c -underline 50 +pack .t.c1 .t.c2 .t.c3 -in .t.f3 -side left -padx 5m -pady 3m \ + -expand y -fill both + +radiobutton .t.r1 -text Radiobutton -value a +radiobutton .t.r2 -text "Explicit\nnewlines\n\nin the text" -value b +radiobutton .t.r3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -value c -underline 50 +pack .t.r1 .t.r2 .t.r3 -in .t.f4 -side left -padx 5m -pady 3m \ + -expand y -fill both + +proc config {option value} { + foreach w {.t.l1 .t.l2 .t.l3 .t.b1 .t.b2 .t.b3 .t.c1 .t.c2 .t.c3 + .t.r1 .t.r2 .t.r3} { + catch {$w configure $option $value} + } +} + +proc config-but {option value} { + foreach w {.t.b1 .t.b2 .t.b3} { + $w configure $option $value + } +} diff --git a/tests/button.test b/tests/button.test new file mode 100644 index 0000000..2c6d082 --- /dev/null +++ b/tests/button.test @@ -0,0 +1,822 @@ +# This file is a Tcl script to test labels, buttons, checkbuttons, and +# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c). It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) button.test 1.39 97/07/31 10:19:02 + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\"" + puts "image, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +proc bogusTrace args { + error "trace aborted" +} +catch {unset value} +catch {unset value2} + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Button.borderWidth 2 +option add *Button.highlightThickness 2 +option add *Button.font {Helvetica -12 bold} + +eval image delete [image names] +image create test image1 +label .l -text Label +button .b -text Button +checkbutton .c -text Checkbutton +radiobutton .r -text Radiobutton +pack .l .b .c .r +update +set i 1 +foreach test { + {-activebackground #012345 #012345 non-existent + {unknown color name "non-existent"}} + {-activeforeground #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} + {-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"}} + {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-command "set x" {set x} {} {}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} + {-fg #110022 #110022 bogus {unknown color name "bogus"}} + {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} + {-foreground #110022 #110022 bogus {unknown color name "bogus"}} + {-height 18 18 20.0 {expected integer but got "20.0"}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} + {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} + {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} + {-image image1 image1 bogus {image "bogus" doesn't exist}} + {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}} + {-justify right right bogus {bad justification "bogus": must be left, right, or center}} + {-offvalue lousy lousy {} {}} + {-offvalue fantastic fantastic {} {}} + {-padx 12 12 420x {bad screen distance "420x"}} + {-pady 12 12 420x {bad screen distance "420x"}} + {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}} + {-selectimage image1 image1 bogus {image "bogus" doesn't exist}} + {-state normal normal bogus {bad state value "bogus": must be normal, active, or disabled}} + {-takefocus "any string" "any string" {} {}} + {-text "Sample text" {Sample text} {} {}} + {-textvariable i i {} {}} + {-underline 5 5 3p {expected integer but got "3p"}} + {-width 402 402 3p {expected integer but got "3p"}} + {-wraplength 100 100 6x {bad screen distance "6x"}} +} { + set name [lindex $test 0] + test button-1.$i {configuration options} { + .c configure $name [lindex $test 1] + lindex [.c configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test button-1.$i {configuration options} { + list [catch {.c configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .c configure $name [lindex [.c configure $name] 3] + incr i +} +test button-1.$i {configuration options} { + .c configure -selectcolor {} +} {} +incr i +# the following tests only work on buttons, not checkbuttons +test button-1.$i {configuration options} { + .b configure -default active + lindex [.b configure -default] 4 +} active +incr i +test button-1.$i {configuration options} { + .b configure -default normal + lindex [.b configure -default] 4 +} normal +incr i +test button-1.$i {configuration options} { + .b configure -default disabled + lindex [.b configure -default] 4 +} disabled +incr i +test button-1.$i {configuration options} { + .b configure -default active + lindex [.b configure -default] 3 +} disabled +incr i +test button-1.$i {configuration options} { + list [catch {.b configure -default no_way} msg] $msg +} {1 {bad -default value "no_way": must be normal, active, or disabled}} + +set i 1 +foreach check { + {-activebackground 1 0 0 0} + {-activeforeground 1 0 0 0} + {-anchor 0 0 0 0} + {-background 0 0 0 0} + {-bd 0 0 0 0} + {-bg 0 0 0 0} + {-bitmap 0 0 0 0} + {-borderwidth 0 0 0 0} + {-command 1 0 0 0} + {-cursor 0 0 0 0} + {-default 1 0 1 1} + {-disabledforeground 1 0 0 0} + {-fg 0 0 0 0} + {-font 0 0 0 0} + {-foreground 0 0 0 0} + {-height 0 0 0 0} + {-image 0 0 0 0} + {-indicatoron 1 1 0 0} + {-offvalue 1 1 0 1} + {-onvalue 1 1 0 1} + {-padx 0 0 0 0} + {-pady 0 0 0 0} + {-relief 0 0 0 0} + {-selectcolor 1 1 0 0} + {-selectimage 1 1 0 0} + {-state 1 0 0 0} + {-text 0 0 0 0} + {-textvariable 0 0 0 0} + {-value 1 1 1 0} + {-variable 1 1 0 0} + {-width 0 0 0 0} +} { + test button-2.$i {label-specific options} " + catch {.l configure [lindex $check 0]} + " [lindex $check 1] + incr i + test button-2.$i {button-specific options} " + catch {.b configure [lindex $check 0]} + " [lindex $check 2] + incr i + test button-2.$i {checkbutton-specific options} " + catch {.c configure [lindex $check 0]} + " [lindex $check 3] + incr i + test button-2.$i {radiobutton-specific options} " + catch {.r configure [lindex $check 0]} + " [lindex $check 4] + incr i +} + +test button-3.1 {ButtonCreate procedure} { + list [catch {button} msg] $msg +} {1 {wrong # args: should be "button pathName ?options?"}} +test button-3.2 {ButtonCreate procedure} { + catch {destroy .x} + label .x + winfo class .x +} {Label} +test button-3.3 {ButtonCreate procedure} { + catch {destroy .x} + button .x + winfo class .x +} {Button} +test button-3.4 {ButtonCreate procedure} { + catch {destroy .x} + checkbutton .x + winfo class .x +} {Checkbutton} +test button-3.5 {ButtonCreate procedure} { + catch {destroy .x} + radiobutton .x + winfo class .x +} {Radiobutton} +rename button gorp +test button-3.6 {ButtonCreate procedure} { + catch {destroy .x} + gorp .x + winfo class .x +} {Button} +rename gorp button +test button-3.7 {ButtonCreate procedure} { + list [catch {button foo} msg] $msg +} {1 {bad window path name "foo"}} +test button-3.8 {ButtonCreate procedure} { + catch {destroy .x} + list [catch {button .x -gorp foo} msg] $msg [winfo exists .x] +} {1 {unknown option "-gorp"} 0} + +test button-4.1 {ButtonWidgetCmd procedure} { + list [catch {.b} msg] $msg +} {1 {wrong # args: should be ".b option ?arg arg ...?"}} +test button-4.2 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.b c} msg] $msg +} {1 {bad option "c": must be cget, configure, flash, or invoke}} +test button-4.3 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.b cget a b} msg] $msg +} {1 {wrong # args: should be ".b cget option"}} +test button-4.4 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.b cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test button-4.5 {ButtonWidgetCmd procedure, "cget" option} { + .b configure -highlightthickness 3 + .b cget -highlightthickness +} {3} +test button-4.6 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.l cget -disabledforeground} msg] $msg +} {1 {unknown option "-disabledforeground"}} +test button-4.7 {ButtonWidgetCmd procedure, "cget" option} { + catch {.b cget -disabledforeground} +} {0} +test button-4.8 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.b cget -variable} msg] $msg +} {1 {unknown option "-variable"}} +test button-4.9 {ButtonWidgetCmd procedure, "cget" option} { + catch {.c cget -variable} +} {0} +test button-4.10 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.c cget -value} msg] $msg +} {1 {unknown option "-value"}} +test button-4.11 {ButtonWidgetCmd procedure, "cget" option} { + catch {.r cget -value} +} {0} +test button-4.12 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.r cget -onvalue} msg] $msg +} {1 {unknown option "-onvalue"}} +test button-4.13 {ButtonWidgetCmd procedure, "configure" option} { + llength [.c configure] +} {36} +test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.b configure -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.b co -bg #ffffff -fg} msg] $msg +} {1 {value for "-fg" missing}} +test button-4.16 {ButtonWidgetCmd procedure, "configure" option} { + .b configure -fg #123456 + .b configure -bg #654321 + lindex [.b configure -fg] 4 +} {#123456} +.c configure -variable value -onvalue 1 -offvalue 0 +.r configure -variable value2 -value red +test button-4.17 {ButtonWidgetCmd procedure, "deselect" option} { + list [catch {.c deselect foo} msg] $msg +} {1 {wrong # args: should be ".c deselect"}} +test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} { + list [catch {.l deselect} msg] $msg +} {1 {bad option "deselect": must be cget or configure}} +test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} { + list [catch {.b deselect} msg] $msg +} {1 {bad option "deselect": must be cget, configure, flash, or invoke}} +test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} { + set value 1 + .c d + set value +} {0} +test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} { + set value2 green + .r deselect + set value2 +} {green} +test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} { + set value2 red + .r deselect + set value2 +} {} +test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { + 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 + while executing +".c deselect"} 0} +test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { + 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 + while executing +".r deselect"} {}} +test button-4.25 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.b flash foo} msg] $msg +} {1 {wrong # args: should be ".b flash"}} +test button-4.26 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.l flash} msg] $msg +} {1 {bad option "flash": must be cget or configure}} +test button-4.27 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.b flash} msg] $msg +} {0 {}} +test button-4.28 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.c flash} msg] $msg +} {0 {}} +test button-4.29 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.r f} msg] $msg +} {0 {}} +test button-4.30 {ButtonWidgetCmd procedure, "invoke" option} { + list [catch {.b invoke foo} msg] $msg +} {1 {wrong # args: should be ".b invoke"}} +test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} { + list [catch {.l invoke} msg] $msg +} {1 {bad option "invoke": must be cget or configure}} +test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} { + .b configure -command {set x invoked} + set x "not invoked" + .b invoke + set x +} {invoked} +test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} { + .b configure -command {set x invoked} -state disabled + set x "not invoked" + .b invoke + set x +} {not invoked} +test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { + set value bogus + .c configure -command {set x invoked} -variable value -onvalue 1 \ + -offvalue 0 + set x "not invoked" + .c invoke + list $x $value +} {invoked 1} +test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} { + set value2 green + .r configure -command {set x invoked} -variable value2 -value red + set x "not invoked" + .r i + list $x $value2 +} {invoked red} +test button-4.36 {ButtonWidgetCmd procedure, "select" option} { + list [catch {.l select} msg] $msg +} {1 {bad option "select": must be cget or configure}} +test button-4.37 {ButtonWidgetCmd procedure, "select" option} { + list [catch {.b select} msg] $msg +} {1 {bad option "select": must be cget, configure, flash, or invoke}} +test button-4.38 {ButtonWidgetCmd procedure, "select" option} { + list [catch {.c select foo} msg] $msg +} {1 {wrong # args: should be ".c select"}} +test button-4.39 {ButtonWidgetCmd procedure, "select" option} { + set value bogus + .c configure -command {} -variable value -onvalue lovely -offvalue 0 + .c s + set value +} {lovely} +test button-4.40 {ButtonWidgetCmd procedure, "select" option} { + set value2 green + .r configure -command {} -variable value2 -value red + .r select + set value2 +} {red} +test button-4.41 {ButtonWidgetCmd procedure, "select" option} { + 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 + while executing +".r select"} red} +test button-4.42 {ButtonWidgetCmd procedure, "toggle" option} { + list [catch {.l toggle} msg] $msg +} {1 {bad option "toggle": must be cget or configure}} +test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} { + list [catch {.b toggle} msg] $msg +} {1 {bad option "toggle": must be cget, configure, flash, or invoke}} +test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} { + list [catch {.r toggle} msg] $msg +} {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}} +test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} { + list [catch {.c toggle foo} msg] $msg +} {1 {wrong # args: should be ".c toggle"}} +test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { + set value bogus + .c configure -command {} -variable value -onvalue sunshine -offvalue rain + .c toggle + set result $value + .c toggle + lappend result $value + .c toggle + lappend result $value +} {sunshine rain sunshine} +test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { + .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 + while executing +".c toggle"} abc} +test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { + .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 + while executing +".c toggle"} xyz} +test button-4.49 {ButtonWidgetCmd procedure} { + list [catch {.c bad_option} msg] $msg +} {1 {bad option "bad_option": must be cget, configure, deselect, flash, invoke, select, or toggle}} +test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} { + catch {unset value}; set value(1) 1; + set result [list [catch {.c toggle} msg] $msg $errorInfo] + unset value; + set result +} {1 {can't set "value": variable is array} {can't set "value": variable is array + while executing +".c toggle"}} + +test button-5.1 {DestroyButton procedure} { + image create test image1 + button .b1 -image image1 + button .b2 -fg #ff0000 -text "Button 2" + button .b3 -state active -text "Button 3" + button .b4 -disabledforeground #0000ff -state disabled -text "Button 4" + checkbutton .b5 -variable x -text "Checkbutton 5" + set x 1 + pack .b1 .b2 .b3 .b4 .b5 + update + eval destroy [winfo children .] +} {} + +test button-6.1 {ConfigureButton procedure} { + catch {destroy .b1} + set x From-x + set y From-y + button .b1 -textvariable x + .b1 configure -textvariable y + set x New + lindex [.b1 configure -text] 4 +} {From-y} +test button-6.2 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + checkbutton .b1 -variable x + set x 1 + set y 1 + .b1 configure -textvariable y + set x 0 + .b1 toggle + set y +} {1} +test button-6.3 {ConfigureButton procedure} { + catch {destroy .b1} + eval image delete [image names] + image create test image1 + image create test image2 + button .b1 -image image1 + image delete image1 + .b1 configure -image image2 + image names +} {image2} +test button-6.4 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -text "Test" -state disabled + list [catch {.b1 configure -state bogus} msg] $msg \ + [lindex [.b1 configure -state] 4] +} {1 {bad state value "bogus": must be normal, active, or disabled} normal} +test button-6.5 {ConfigureButton procedure} { + catch {destroy .b1} + checkbutton .b1 + .b1 cget -variable +} {b1} +test button-6.6 {ConfigureButton procedure} { + catch {destroy .b1} + set x 0 + set y Shiny + checkbutton .b1 -variable x + .b1 configure -variable y -onvalue Shiny + .b1 toggle + set y +} 0 +test button-6.7 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + checkbutton .b1 -variable x -offvalue Bogus + set x +} Bogus +test button-6.8 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + radiobutton .b1 -variable x + set x +} {} +test button-6.9 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + trace variable x w bogusTrace + set result [list [catch {radiobutton .b1 -variable x} msg] $msg] + trace vdelete x w bogusTrace + set result +} {1 {can't set "x": trace aborted}} +test button-6.10 {ConfigureButton procedure} { + catch {destroy .b1} + list [catch {button .b1 -image bogus} msg] $msg +} {1 {image "bogus" doesn't exist}} +test button-6.11 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + button .b1 -textvariable x -text "Button 1" + set x +} {Button 1} +test button-6.12 {ConfigureButton procedure} { + catch {destroy .b1} + set x Override + button .b1 -textvariable x -text "Button 1" + set x +} {Override} +test button-6.13 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + trace variable x w bogusTrace + set result [list [catch {radiobutton .b1 -text foo -textvariable x} msg] \ + $msg $x] + trace vdelete x w bogusTrace + set result +} {1 {can't set "x": trace aborted} foo} +test button-6.14 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -text "Button 1" + list [catch {.b1 configure -width 1i} msg] $msg $errorInfo +} {1 {expected integer but got "1i"} {expected integer but got "1i" + (processing -width option) + invoked from within +".b1 configure -width 1i"}} +test button-6.15 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -text "Button 1" + list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo +} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c" + (processing -height option) + invoked from within +".b1 configure -height 0.5c"}} +test button-6.16 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -bitmap questhead + list [catch {.b1 configure -width abc} msg] $msg $errorInfo +} {1 {bad screen distance "abc"} {bad screen distance "abc" + (processing -width option) + invoked from within +".b1 configure -width abc"}} +test button-6.17 {ConfigureButton procedure} { + catch {destroy .b1} + eval image delete [image names] + image create test image1 + button .b1 -image image1 + list [catch {.b1 configure -height 0.5x} msg] $msg $errorInfo +} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x" + (processing -height option) + invoked from within +".b1 configure -height 0.5x"}} +test button-6.18 {ConfigureButton procedure} {nonPortable fonts} { + catch {destroy .b1} + button .b1 -text "Sample text" -width 10 -height 2 + pack .b1 + set result "[winfo reqwidth .b1] [winfo reqheight .b1]" + .b1 configure -bitmap questhead + lappend result [winfo reqwidth .b1] [winfo reqheight .b1] +} {102 46 20 12} +test button-6.19 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -text "Button 1" + set old [winfo reqwidth .b1] + .b1 configure -text "Much longer text" + set new [winfo reqwidth .b1] + expr $old == $new +} {0} + +test button-7.1 {ButtonEventProc procedure} { + catch {destroy .b1} + button .b1 -text "Test Button" -command { + destroy .b1 + set x [list [winfo exists .b1] [info commands .b1]] + } + .b1 invoke + set x +} {0 {}} +test button-7.2 {ButtonEventProc procedure} { + eval destroy [winfo children .] + button .b1 -bg #543210 + rename .b1 .b2 + set x {} + lappend x [winfo children .] + lappend x [.b2 cget -bg] + destroy .b1 + lappend x [info command .b*] [winfo children .] +} {.b1 #543210 {} {}} + +test button-8.1 {ButtonCmdDeletedProc procedure} { + eval destroy [winfo children .] + button .b1 + rename .b1 {} + list [info command .b*] [winfo children .] +} {{} {}} + +test button-9.1 {TkInvokeButton procedure} { + catch {destroy .b1} + set x 0 + checkbutton .b1 -variable x + set result $x + .b1 invoke + lappend result $x + .b1 invoke + lappend result $x +} {0 1 0} +test button-9.2 {TkInvokeButton procedure} { + catch {destroy .b1} + set x 0 + checkbutton .b1 -variable x + trace variable x w bogusTrace + set result [list [catch {.b1 invoke} msg] $msg $x] + trace vdelete x w bogusTrace + set result +} {1 {can't set "x": trace aborted} 1} +test button-9.3 {TkInvokeButton procedure} { + catch {destroy .b1} + set x 1 + checkbutton .b1 -variable x + trace variable x w bogusTrace + set result [list [catch {.b1 invoke} msg] $msg $x] + trace vdelete x w bogusTrace + set result +} {1 {can't set "x": trace aborted} 0} +test button-9.4 {TkInvokeButton procedure} { + catch {destroy .b1} + set x 0 + radiobutton .b1 -variable x -value red + set result $x + .b1 invoke + lappend result $x + .b1 invoke + lappend result $x +} {0 red red} +test button-9.5 {TkInvokeButton procedure} { + catch {destroy .b1} + radiobutton .b1 -variable x -value red + set x green + trace variable x w bogusTrace + 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 + while executing +".b1 invoke"} red} +test button-9.6 {TkInvokeButton procedure} { + eval destroy [winfo children .] + set result untouched + button .b1 -command {set result invoked} + list [catch {.b1 invoke} msg] $msg $result +} {0 invoked invoked} +test button-9.7 {TkInvokeButton procedure} { + eval destroy [winfo children .] + set result untouched + set x 0 + checkbutton .b1 -variable x -command {set result "invoked $x"} + list [catch {.b1 invoke} msg] $msg $result +} {0 {invoked 1} {invoked 1}} +test button-9.8 {TkInvokeButton procedure} { + eval destroy [winfo children .] + set result untouched + set x 0 + radiobutton .b1 -variable x -value red -command {set result "invoked $x"} + list [catch {.b1 invoke} msg] $msg $result +} {0 {invoked red} {invoked red}} + +test button-10.1 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 1 + checkbutton .b1 -variable x + unset x + set result [info exists x] + .b1 toggle + lappend result $x + set x 0 + .b1 toggle + lappend result $x +} {0 1 1} +test button-10.2 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 0 + checkbutton .b1 -variable x + set x 44 + .b1 toggle + set x +} {1} +test button-10.3 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 1 + checkbutton .b1 -variable x + set x 44 + .b1 toggle + set x +} {1} +test button-10.4 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 0 + checkbutton .b1 -variable x + set x 1 + .b1 toggle + set x +} {0} +test button-10.5 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 1 + checkbutton .b1 -variable x + set x 1 + .b1 toggle + set x +} {0} +test button-10.6 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 0 + checkbutton .b1 -variable x + set x 0 + .b1 toggle + set x +} {1} +test button-10.7 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 1 + checkbutton .b1 -variable x + set x 0 + .b1 toggle + set x +} {1} +test button-10.8 {ButtonVarProc procedure, can't read variable} { + # This test does nothing but produce a core dump if there's a prbblem. + eval destroy [winfo children .] + catch {unset a} + checkbutton .b1 -variable a + unset a + set a(32) 0 + unset a +} {} + +test button-11.1 {ButtonTextVarProc procedure} { + eval destroy [winfo children .] + set x Label + button .b1 -textvariable x + unset x + set result [list $x [lindex [.b1 configure -text] 4]] + set x New + lappend result [lindex [.b1 configure -text] 4] +} {Label Label New} +test button-11.2 {ButtonTextVarProc procedure} { + eval destroy [winfo children .] + set x Label + button .b1 -textvariable x + set old [winfo reqwidth .b1] + set x New + set new [winfo reqwidth .b1] + list [lindex [.b1 configure -text] 4] [expr $old == $new] +} {New 0} + +test button-12.1 {ButtonImageProc procedure} { + eval destroy [winfo children .] + eval image delete [image names] + image create test image1 + label .b1 -image image1 -padx 0 -pady 0 -bd 0 + pack .b1 + set result "[winfo reqwidth .b1] [winfo reqheight .b1]" + image1 changed 0 0 0 0 80 100 + lappend result [winfo reqwidth .b1] [winfo reqheight .b1] +} {30 15 80 100} + +eval destroy [winfo children .] +set l [interp hidden] + +test button-13.1 {button widget vs hidden commands} { + catch {destroy .b} + button .b -text hello + interp hide {} .b + destroy .b + list [winfo children .] [interp hidden] +} [list {} $l] + +eval destroy [winfo children .] + +option clear + diff --git a/tests/canvImg.test b/tests/canvImg.test new file mode 100644 index 0000000..59ceaa2 --- /dev/null +++ b/tests/canvImg.test @@ -0,0 +1,397 @@ +# This file is a Tcl script to test out the procedures in tkCanvImg.c, +# which implement canvas "image" items. It is organized in the standard +# fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) canvImg.test 1.17 97/07/02 11:28:26 + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +eval image delete [image names] +canvas .c +pack .c +update +image create test foo -variable x +image create test foo2 -variable y +foo2 changed 0 0 0 0 80 60 +test canvImg-1.1 {options for image items} { + .c delete all + .c create image 50 50 -anchor nw -tags i1 + .c itemconfigure i1 -anchor +} {-anchor {} {} center nw} +test canvImg-1.2 {options for image items} { + .c delete all + list [catch {.c create image 50 50 -anchor gorp -tags i1} msg] $msg +} {1 {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}} +test canvImg-1.3 {options for image items} { + .c delete all + .c create image 50 50 -image foo -tags i1 + .c itemconfigure i1 -image +} {-image {} {} {} foo} +test canvImg-1.4 {options for image items} { + .c delete all + list [catch {.c create image 50 50 -image unknown -tags i1} msg] $msg +} {1 {image "unknown" doesn't exist}} +test canvImg-1.5 {options for image items} { + .c delete all + .c create image 50 50 -image foo -tags {i1 foo} + .c itemconfigure i1 -tags +} {-tags {} {} {} {i1 foo}} + +test canvImg-2.1 {CreateImage procedure} { + list [catch {.c create image 40} msg] $msg +} {1 {wrong # args: should be ".c create image x y ?options?"}} +test canvImg-2.2 {CreateImage procedure} { + list [catch {.c create image 40 50 60} msg] $msg +} {1 {unknown option "60"}} +test canvImg-2.3 {CreateImage procedure} { + .c delete all + set i [.c create image 50 50] + list [lindex [.c itemconf $i -anchor] 4] \ + [lindex [.c itemconf $i -image] 4] \ + [lindex [.c itemconf $i -tags] 4] +} {center {} {}} +test canvImg-2.4 {CreateImage procedure} { + list [catch {.c create image xyz 40} msg] $msg +} {1 {bad screen distance "xyz"}} +test canvImg-2.5 {CreateImage procedure} { + list [catch {.c create image 50 qrs} msg] $msg +} {1 {bad screen distance "qrs"}} +test canvImg-2.6 {CreateImage procedure} { + list [catch {.c create image 50 50 -gorp foo} msg] $msg +} {1 {unknown option "-gorp"}} + +test canvImg-3.1 {ImageCoords procedure} { + .c delete all + .c create image 50 100 -image foo -tags i1 + .c coords i1 +} {50.0 100.0} +test canvImg-3.2 {ImageCoords procedure} { + .c delete all + .c create image 50 100 -image foo -tags i1 + list [catch {.c coords i1 dumb 100} msg] $msg +} {1 {bad screen distance "dumb"}} +test canvImg-3.3 {ImageCoords procedure} { + .c delete all + .c create image 50 100 -image foo -tags i1 + list [catch {.c coords i1 250 dumb0} msg] $msg +} {1 {bad screen distance "dumb0"}} +test canvImg-3.4 {ImageCoords procedure} { + .c delete all + .c create image 50 100 -image foo -tags i1 + list [catch {.c coords i1 250} msg] $msg +} {1 {wrong # coordinates: expected 0 or 2, got 1}} +test canvImg-3.5 {ImageCoords procedure} { + .c delete all + .c create image 50 100 -image foo -tags i1 + list [catch {.c coords i1 250 300 400} msg] $msg +} {1 {wrong # coordinates: expected 0 or 2, got 3}} + +test canvImg-4.1 {ConfiugreImage procedure} { + .c delete all + .c create image 50 100 -image foo -tags i1 + update + set x {} + .c itemconfigure i1 -image {} + update + list $x [.c bbox i1] +} {{{foo free}} {}} +test canvImg-4.2 {ConfiugreImage procedure} { + .c delete all + .c create image 50 100 -image foo -tags i1 -anchor nw + update + set x {} + set y {} + .c itemconfigure i1 -image foo2 + update + list $x $y [.c bbox i1] +} {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}} +test canvImg-4.3 {ConfiugreImage procedure} { + .c delete all + .c create image 50 100 -image foo -tags i1 -anchor nw + update + set x {} + set y {} + list [catch {.c itemconfigure i1 -image lousy} msg] $msg +} {1 {image "lousy" doesn't exist}} + +test canvImg-5.1 {DeleteImage procedure} { + image create test xyzzy -variable z + .c delete all + .c create image 50 100 -image xyzzy -tags i1 + update + image delete xyzzy + set z {} + set names [lsort [image names]] + .c delete i1 + update + list $names $z [lsort [image names]] +} {{foo foo2 xyzzy} {} {foo foo2}} +test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} { + .c delete all + .c create image 50 100 -tags i1 + update + .c delete i1 + update +} {} + +test canvImg-6.1 {ComputeImageBbox procedure} { + .c delete all + .c create image 15.51 17.51 -image foo -tags i1 -anchor nw + .c bbox i1 +} {16 18 46 33} +test canvImg-6.2 {ComputeImageBbox procedure} { + .c delete all + .c create image 15.49 17.49 -image foo -tags i1 -anchor nw + .c bbox i1 +} {15 17 45 32} +test canvImg-6.3 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -tags i1 -anchor nw + .c bbox i1 +} {} +test canvImg-6.4 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -image foo -tags i1 -anchor nw + .c bbox i1 +} {20 30 50 45} +test canvImg-6.5 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -image foo -tags i1 -anchor n + .c bbox i1 +} {5 30 35 45} +test canvImg-6.6 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -image foo -tags i1 -anchor ne + .c bbox i1 +} {-10 30 20 45} +test canvImg-6.7 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -image foo -tags i1 -anchor e + .c bbox i1 +} {-10 23 20 38} +test canvImg-6.8 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -image foo -tags i1 -anchor se + .c bbox i1 +} {-10 15 20 30} +test canvImg-6.9 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -image foo -tags i1 -anchor s + .c bbox i1 +} {5 15 35 30} +test canvImg-6.10 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -image foo -tags i1 -anchor sw + .c bbox i1 +} {20 15 50 30} +test canvImg-6.11 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -image foo -tags i1 -anchor w + .c bbox i1 +} {20 23 50 38} +test canvImg-6.12 {ComputeImageBbox procedure} { + .c delete all + .c create image 20 30 -image foo -tags i1 -anchor center + .c bbox i1 +} {5 23 35 38} + +# The following test is non-portable because of differences in +# coordinate rounding on some machines (does 0.5 round up?). + +test canvImg-7.1 {DisplayImage procedure} {nonPortable} { + .c delete all + .c create image 50 100 -image foo -tags i1 -anchor nw + update + set x {} + .c create rect 55 110 65 115 -width 1 -outline black -fill white + update + set x +} {{foo display 4 9 12 6 30 30}} +test canvImg-7.2 {DisplayImage procedure, no image} { + .c delete all + .c create image 50 100 -tags i1 + update + .c create rect 55 110 65 115 -width 1 -outline black -fill white + update +} {} + +set i 1 +.c delete all +.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}} +} { + test canvImg-8.$i {ImageToPoint procedure} { + eval .c coords rect [lindex $check 0] + .c gettags [eval .c find closest [lindex $check 1]] + } [lindex $check 2] + incr i +} + +.c delete all +.c create image 50 100 -image foo -tags image -anchor nw +test canvImg-8.19 {ImageToArea procedure} { + .c gettags [.c find overlapping 60 0 70 99] +} {} +test canvImg-8.20 {ImageToArea procedure} { + .c gettags [.c find overlapping 60 0 70 99.999] +} {} +test canvImg-8.21 {ImageToArea procedure} { + .c gettags [.c find overlapping 60 0 70 101] +} {image} +test canvImg-8.22 {ImageToArea procedure} { + .c gettags [.c find overlapping 81 105 120 115] +} {} +test canvImg-8.23 {ImageToArea procedure} { + .c gettags [.c find overlapping 80.001 105 120 115] +} {} +test canvImg-8.24 {ImageToArea procedure} { + .c gettags [.c find overlapping 79 105 120 115] +} {image} +test canvImg-8.25 {ImageToArea procedure} { + .c gettags [.c find overlapping 60 116 70 150] +} {} +test canvImg-8.26 {ImageToArea procedure} { + .c gettags [.c find overlapping 60 115.001 70 150] +} {} +test canvImg-8.27 {ImageToArea procedure} { + .c gettags [.c find overlapping 60 114 70 150] +} {image} +test canvImg-8.28 {ImageToArea procedure} { + .c gettags [.c find overlapping 0 105 49 115] +} {} +test canvImg-8.29 {ImageToArea procedure} { + .c gettags [.c find overlapping 0 105 50 114.999] +} {} +test canvImg-8.30 {ImageToArea procedure} { + .c gettags [.c find overlapping 0 105 51 115] +} {image} +test canvImg-8.31 {ImageToArea procedure} { + .c gettags [.c find overlapping 0 0 49.999 99.999] +} {} +test canvImg-8.32 {ImageToArea procedure} { + .c gettags [.c find overlapping 0 0 51 101] +} {image} +test canvImg-8.33 {ImageToArea procedure} { + .c gettags [.c find overlapping 80 0 150 100] +} {} +test canvImg-8.34 {ImageToArea procedure} { + .c gettags [.c find overlapping 79 0 150 101] +} {image} +test canvImg-8.35 {ImageToArea procedure} { + .c gettags [.c find overlapping 80.001 115.001 150 180] +} {} +test canvImg-8.36 {ImageToArea procedure} { + .c gettags [.c find overlapping 79 114 150 180] +} {image} +test canvImg-8.37 {ImageToArea procedure} { + .c gettags [.c find overlapping 0 115 50 180] +} {} +test canvImg-8.38 {ImageToArea procedure} { + .c gettags [.c find overlapping 0 114 51 180] +} {image} +test canvImg-8.39 {ImageToArea procedure} { + .c gettags [.c find enclosed 0 0 200 200] +} {image} +test canvImg-8.40 {ImageToArea procedure} { + .c gettags [.c find enclosed 49.999 99.999 80.001 115.001] +} {image} +test canvImg-8.41 {ImageToArea procedure} { + .c gettags [.c find enclosed 51 100 80 115] +} {} +test canvImg-8.42 {ImageToArea procedure} { + .c gettags [.c find enclosed 50 101 80 115] +} {} +test canvImg-8.43 {ImageToArea procedure} { + .c gettags [.c find enclosed 50 100 79 115] +} {} +test canvImg-8.44 {ImageToArea procedure} { + .c gettags [.c find enclosed 50 100 80 114] +} {} + +test canvImg-9.1 {DisplayImage procedure} { + .c delete all + .c create image 50 100 -image foo -tags image -anchor nw + .c scale image 25 0 2.0 1.5 + .c bbox image +} {75 150 105 165} + +test canvImg-10.1 {TranslateImage procedure} { + .c delete all + .c create image 50 100 -image foo -tags image -anchor nw + update + set x {} + foo changed 2 4 6 8 30 15 + update + set x +} {{foo display 2 4 6 8 30 30}} + +test canvImg-11.1 {TranslateImage procedure} { + .c delete all + .c create image 50 100 -image foo -tags image -anchor nw + update + set x {} + foo changed 2 4 6 8 40 50 + update + set x +} {{foo display 0 0 40 50 30 30}} +test canvImg-11.2 {ImageChangedProc procedure} { + .c delete all + image create test foo -variable x + .c create image 50 100 -image foo -tags image -anchor center + update + set x {} + foo changed 0 0 0 0 40 50 + .c bbox image +} {30 75 70 125} +test canvImg-11.3 {ImageChangedProc procedure} { + .c delete all + image create test foo -variable x + foo changed 0 0 0 0 40 50 + .c create image 50 100 -image foo -tags image -anchor nw + .c create image 70 110 -image foo2 -anchor nw + update + set y {} + image create test foo -variable x + update + set y +} {{foo2 display 0 0 20 40 50 40}} diff --git a/tests/canvPs.test b/tests/canvPs.test new file mode 100644 index 0000000..5ee56b9 --- /dev/null +++ b/tests/canvPs.test @@ -0,0 +1,105 @@ +# This file is a Tcl script to test out procedures to write postscript +# for canvases to files and channels. It exercises the procedure +# TkCanvPostscriptCmd in generic/tkCanvPs.c +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) canvPs.test 1.5 97/06/10 15:49:35 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +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} { + removeFile foo.ps + removeFile bar.ps + .c postscript -file foo.ps + .c postscript -file bar.ps + set status ok + if {[file size bar.ps] != [file size foo.ps]} { + set status broken + } + set status +} ok + +test canvPs-2.1 {test writing to a channel} {unixOrPc} { + removeFile foo.ps + set chan [open foo.ps 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} { + removeFile foo.ps + removeFile bar.ps + set c1 [open foo.ps w] + set c2 [open bar.ps w] + fconfigure $c1 -translation lf + fconfigure $c2 -translation lf + .c postscript -channel $c1 + .c postscript -channel $c2 + close $c1 + close $c2 + set status ok + if {[file size bar.ps] != [file size foo.ps]} { + set status broken + } + set status +} ok +test canvPs-2.3 {test writing to channel and file, same output} {unixOnly} { + removeFile foo.ps + removeFile bar.ps + set c1 [open foo.ps w] + fconfigure $c1 -translation lf + .c postscript -channel $c1 + close $c1 + .c postscript -file bar.ps + set status ok + if {[file size foo.ps] != [file size bar.ps]} { + set status broken + } + set status +} ok +test canvPs-2.4 {test writing to channel and file, same output} {pcOnly} { + removeFile foo.ps + removeFile bar.ps + set c1 [open foo.ps w] + fconfigure $c1 -translation crlf + .c postscript -channel $c1 + close $c1 + .c postscript -file bar.ps + set status ok + if {[file size foo.ps] != [file size bar.ps]} { + set status broken + } + set status +} ok + +# Clean-up + +removeFile foo.ps +removeFile bar.ps + +foreach i [winfo children .] { + destroy $i +} diff --git a/tests/canvPsArc.tcl b/tests/canvPsArc.tcl new file mode 100644 index 0000000..333765a --- /dev/null +++ b/tests/canvPsArc.tcl @@ -0,0 +1,45 @@ +# This file creates a screen to exercise Postscript generation +# for bitmaps in canvases. It is part of the Tk visual test suite, +# which is invoked via the "visual" script. +# +# SCCS: @(#) canvPsArc.tcl 1.3 96/02/16 10:55:43 + +catch {destroy .t} +toplevel .t +wm title .t "Postscript Tests for Canvases" +wm iconname .t "Postscript" +wm geom .t +0+0 +wm minsize .t 1 1 + +set c .t.c + +message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for arcs. Click on "Print" to print the canvas to your default printer. You can click on items in the canvas to delete them.} -width 6i +pack .t.m -side top -fill both + +frame .t.bot +pack .t.bot -side bottom -fill both +button .t.bot.quit -text Quit -command {destroy .t} +button .t.bot.print -text Print -command "lpr $c" +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 + +$c create arc .5i .5i 2i 2i -style pieslice -start 20 -extent 90 \ + -fill black -outline {} +$c create arc 2.5i 0 4.5i 1i -style pieslice -start -45 -extent -135 \ + -fill {} -outline black -outlinestipple gray50 -width 3m +$c create arc 5.0i .5i 6.5i 2i -style pieslice -start 45 -extent 315 \ + -fill black -stipple gray25 -outline black -width 1m + +$c create arc -.5i 2.5i 2.0i 3.5i -style chord -start 90 -extent 270 \ + -fill black -outline {} +$c create arc 2.5i 2i 4i 6i -style chord -start 20 -extent 140 \ + -fill black -stipple gray50 -outline black -width 2m +$c create arc 4i 2.5i 8i 4.5i -style chord -start 60 -extent 60 \ + -fill {} -outline black + +$c create arc .5i 4.5i 2i 6i -style arc -start 135 -extent 315 -width 3m \ + -outline black -outlinestipple gray25 +$c create arc 3.5i 4.5i 5.5i 5.5i -style arc -start 45 -extent -90 -width 1m \ + -outline black diff --git a/tests/canvPsBmap.tcl b/tests/canvPsBmap.tcl new file mode 100644 index 0000000..385e998 --- /dev/null +++ b/tests/canvPsBmap.tcl @@ -0,0 +1,71 @@ +# This file creates a screen to exercise Postscript generation +# for bitmaps in canvases. It is part of the Tk visual test suite, +# which is invoked via the "visual" script. +# +# SCCS: @(#) canvPsBmap.tcl 1.5 96/07/25 15:54:14 + +catch {destroy .t} +toplevel .t +wm title .t "Postscript Tests for Canvases" +wm iconname .t "Postscript" +wm geom .t +0+0 +wm minsize .t 1 1 + +set c .t.c + +message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for bitmaps. Click on "Print" to print the canvas to your default printer. You can click on items in the canvas to delete them.} -width 6i +pack .t.m -side top -fill both + +frame .t.bot +pack .t.bot -side bottom -fill both +button .t.bot.quit -text Quit -command {destroy .t} +button .t.bot.print -text Print -command "lpr $c" +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 + +$c create bitmap 0.5i 0.5i \ + -bitmap @[file join $tk_library demos/images/flagdown.bmp] \ + -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] \ + -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] \ + -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] \ + -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] \ + -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] \ + -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] \ + -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] \ + -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] \ + -background {} -foreground black -anchor se +$c create rect 5.47i 5.47i 5.53i 5.53i -fill {} -outline black diff --git a/tests/canvPsGrph.tcl b/tests/canvPsGrph.tcl new file mode 100644 index 0000000..55b90d7 --- /dev/null +++ b/tests/canvPsGrph.tcl @@ -0,0 +1,87 @@ +# This file creates a screen to exercise Postscript generation +# for some of the graphical objects in canvases. It is part of the Tk +# visual test suite, which is invoked via the "visual" script. +# +# SCCS: @(#) canvPsGrph.tcl 1.3 96/02/16 10:56:07 + +catch {destroy .t} +toplevel .t +wm title .t "Postscript Tests for Canvases" +wm iconname .t "Postscript" +wm geom .t +0+0 +wm minsize .t 1 1 + +set c .t.mid.c + +message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets. Select what you want to display with the buttons below, then click on "Print" to print it to your default printer. You can click on items in the canvas to delete them.} -width 4i +pack .t.m -side top -fill both + +frame .t.top +pack .t.top -side top -fill both +set what rect +radiobutton .t.top.rect -text Rectangles -variable what -value rect \ + -command "mkObjs $c" -relief flat +radiobutton .t.top.oval -text Ovals -variable what -value oval \ + -command "mkObjs $c" -relief flat +radiobutton .t.top.poly -text Polygons -variable what -value poly \ + -command "mkObjs $c" -relief flat +radiobutton .t.top.line -text Lines -variable what -value line \ + -command "mkObjs $c" -relief flat +pack .t.top.rect .t.top.oval .t.top.poly .t.top.line \ + -side left -pady 2m -ipadx 2m -ipady 1m -expand 1 + +frame .t.bot +pack .t.bot -side bottom -fill both +button .t.bot.quit -text Quit -command {destroy .t} +button .t.bot.print -text Print -command "lpr $c" +pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1 + +frame .t.mid -relief sunken -bd 2 +pack .t.mid -side top -expand yes -fill both -padx 2m -pady 2m +canvas $c -width 400 -height 350 -bd 0 -relief sunken +pack $c -expand yes -fill both -padx 1 -pady 1 + +proc mkObjs c { + global what + $c delete all + if {$what == "rect"} { + $c create rect 0 0 400 350 -outline black + $c create rect 2 2 100 50 -fill black -stipple gray25 + $c create rect -20 180 80 320 -fill black -stipple gray50 -width .5c + $c create rect 200 -20 240 20 -fill black + $c create rect 380 200 420 240 -fill black + $c create rect 200 330 240 370 -fill black + } + + if {$what == "oval"} { + $c create oval 50 10 150 80 -fill black -stipple gray25 -outline {} + $c create oval 100 100 200 150 -outline {} -fill black -stipple gray50 + $c create oval 250 100 400 300 -width .5c + } + + if {$what == "poly"} { + $c create poly 100 200 200 50 300 200 -smooth yes -stipple gray25 \ + -outline black -width 4 + $c create poly 100 300 100 250 350 250 350 300 350 300 100 300 100 300 \ + -fill red -smooth yes + $c create poly 20 10 40 10 40 60 80 60 80 25 30 25 30 \ + 35 50 35 50 45 20 45 + $c create poly 300 20 300 120 380 80 320 100 -fill blue -outline black + $c create poly 20 200 100 220 90 100 40 250 \ + -fill {} -outline brown -width 3 + } + + if {$what == "line"} { + $c create line 20 20 120 20 -arrow both -width 5 + $c create line 20 80 150 80 20 200 150 200 -smooth yes + $c create line 150 20 150 150 250 150 -width .5c -smooth yes \ + -arrow both -arrowshape {.75c 1.0c .5c} -stipple gray25 + $c create line 50 340 100 250 150 340 -join round -cap round -width 10 + $c create line 200 340 250 250 300 340 -join bevel -cap project \ + -width 10 + $c create line 300 20 380 20 300 150 380 150 -join miter -cap butt \ + -width 10 -stipple gray25 + } +} + +mkObjs $c diff --git a/tests/canvPsText.tcl b/tests/canvPsText.tcl new file mode 100644 index 0000000..8bcc713 --- /dev/null +++ b/tests/canvPsText.tcl @@ -0,0 +1,83 @@ +# This file creates a screen to exercise Postscript generation +# for text in canvases. It is part of the Tk visual test suite, +# which is invoked via the "visual" script. +# +# SCCS: @(#) canvPsText.tcl 1.3 96/06/24 16:49:12 + +catch {destroy .t} +toplevel .t +wm title .t "Postscript Tests for Canvases" +wm iconname .t "Postscript" +wm geom .t +0+0 +wm minsize .t 1 1 + +set c .t.c + +message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for text. Click on "Print" to print the canvas to your default printer. The "Stipple" button can be used to turn stippling on and off for the text, but beware: many Postscript printers cannot handle stippled text. You can click on items in the canvas to delete them.} -width 6i +pack .t.m -side top -fill both + +set stipple {} +checkbutton .t.stipple -text Stippling -variable stipple -onvalue gray50 \ + -offvalue {} -command "setStipple $c" -relief flat +pack .t.stipple -side top -pady 2m -expand 1 -anchor w + +frame .t.bot +pack .t.bot -side bottom -fill both +button .t.bot.quit -text Quit -command {destroy .t} +button .t.bot.print -text Print -command "lpr $c" +pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1 + +canvas $c -width 6i -height 7i -bd 2 -relief sunken +pack $c -expand yes -fill both -padx 2m -pady 2m + +$c create rect 2.95i 0.45i 3.05i 0.55i -fill {} -outline black +$c create text 3.0i 0.5i -text "Center Courier Oblique 24" \ + -anchor center -tags text -font {Courier 24 italic} -stipple $stipple +$c create rect 2.95i 0.95i 3.05i 1.05i -fill {} -outline black +$c create text 3.0i 1.0i -text "Northwest Helvetica 24" \ + -anchor nw -tags text -font {Helvetica 24} -stipple $stipple +$c create rect 2.95i 1.45i 3.05i 1.55i -fill {} -outline black +$c create text 3.0i 1.5i -text "North Helvetica Oblique 12 " \ + -anchor n -tags text -font {Helvetica 12 italic} -stipple $stipple +$c create rect 2.95i 1.95i 3.05i 2.05i -fill {} -outline blue +$c create text 3.0i 2.0i -text "Northeast Helvetica Bold 24" \ + -anchor ne -tags text -font {Helvetica 24 bold} -stipple $stipple +$c create rect 2.95i 2.45i 3.05i 2.55i -fill {} -outline black +$c create text 3.0i 2.5i -text "East Helvetica Bold Oblique 18" \ + -anchor e -tags text -font {Helvetica 18 {bold italic}} -stipple $stipple +$c create rect 2.95i 2.95i 3.05i 3.05i -fill {} -outline black +$c create text 3.0i 3.0i -text "Southeast Times 10" \ + -anchor se -tags text -font {Times 10} -stipple $stipple +$c create rect 2.95i 3.45i 3.05i 3.55i -fill {} -outline black +$c create text 3.0i 3.5i -text "South Times Italic 24" \ + -anchor s -tags text -font {Times 24 italic} -stipple $stipple +$c create rect 2.95i 3.95i 3.05i 4.05i -fill {} -outline black +$c create text 3.0i 4.0i -text "Southwest Times Bold 18" \ + -anchor sw -tags text -font {Times 18 bold} -stipple $stipple +$c create rect 2.95i 4.45i 3.05i 4.55i -fill {} -outline black +$c create text 3.0i 4.5i -text "West Times Bold Italic 24"\ + -anchor w -tags text -font {Times 24 {bold italic}} -stipple $stipple + +$c create rect 0.95i 5.20i 1.05i 5.30i -fill {} -outline black +$c create text 1.0i 5.25i -width 1.9i -anchor c -justify left -tags text \ + -font {Times 18 bold} -stipple $stipple \ + -text "This is a sample text item to see how left justification works" +$c create rect 2.95i 5.20i 3.05i 5.30i -fill {} -outline black +$c create text 3.0i 5.25i -width 1.8i -anchor c -justify center -tags text \ + -font {Times 18 bold} -stipple $stipple \ + -text "This is a sample text item to see how center justification works" +$c create rect 4.95i 5.20i 5.05i 5.30i -fill {} -outline black +$c create text 5.0i 5.25i -width 1.8i -anchor c -justify right -tags text \ + -font {Times 18 bold} -stipple $stipple \ + -text "This is a sample text item to see how right justification works" + +$c create text 3.0i 6.0i -width 5.0i -anchor n -justify right -tags text \ + -text "This text is\nright justified\nwith a line length equal to\n\ + the size of the enclosing rectangle.\nMake sure it prints right\ + justified as well." +$c create rect 0.5i 6.0i 5.5i 6.9i -fill {} -outline black + +proc setStipple c { + global stipple + $c itemconfigure text -stipple $stipple +} diff --git a/tests/canvRect.test b/tests/canvRect.test new file mode 100644 index 0000000..e910906 --- /dev/null +++ b/tests/canvRect.test @@ -0,0 +1,329 @@ +# This file is a Tcl script to test out the procedures in tkRectOval.c, +# which implement canvas "rectangle" and "oval" items. It is organized +# in the standard fashion for Tcl tests. +# +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) canvRect.test 1.18 97/08/06 15:33:39 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +canvas .c -width 400 -height 300 -bd 2 -relief sunken +pack .c +bind .c <1> { + puts "button down at (%x,%y)" +} +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 6 abc {bad screen distance "abc"}} +} { + set name [lindex $test 0] + test canvRect-1.$i {configuration options} { + .c itemconfigure test $name [lindex $test 1] + list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name] + } [list [lindex $test 2] [lindex $test 2]] + 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]] + } + incr i +} +test canvRect-1.$i {configuration options} { + .c itemconfigure test -tags {test xyz} + .c itemcget xyz -tags +} {test xyz} + +test canvRect-2.1 {CreateRectOval procedure} { + list [catch {.c create rect} msg] $msg +} {1 {wrong # args: should be ".c create rectangle x1 y1 x2 y2 ?options?"}} +test canvRect-2.2 {CreateRectOval procedure} { + list [catch {.c create oval x y z} msg] $msg +} {1 {wrong # args: should be ".c create oval x1 y1 x2 y2 ?options?"}} +test canvRect-2.3 {CreateRectOval procedure} { + list [catch {.c create rectangle x 2 3 4} msg] $msg +} {1 {bad screen distance "x"}} +test canvRect-2.4 {CreateRectOval procedure} { + list [catch {.c create rectangle 1 y 3 4} msg] $msg +} {1 {bad screen distance "y"}} +test canvRect-2.5 {CreateRectOval procedure} { + list [catch {.c create rectangle 1 2 z 4} msg] $msg +} {1 {bad screen distance "z"}} +test canvRect-2.6 {CreateRectOval procedure} { + list [catch {.c create rectangle 1 2 3 q} msg] $msg +} {1 {bad screen distance "q"}} +test canvRect-2.7 {CreateRectOval procedure} { + .c create rectangle 1 2 3 4 -tags x + set result {} + foreach element [.c coords x] { + lappend result [format %.1f $element] + } + set result +} {1.0 2.0 3.0 4.0} +test canvRect-2.8 {CreateRectOval procedure} { + list [catch {.c create rectangle 1 2 3 4 -gorp foo} msg] $msg +} {1 {unknown option "-gorp"}} + +.c delete withtag all +.c create rectangle 10 20 30 40 -tags x +test canvRect-3.1 {RectOvalCoords procedure} { + set result {} + foreach element [.c coords x] { + lappend result [format %.1f $element] + } + set result +} {10.0 20.0 30.0 40.0} +test canvRect-3.2 {RectOvalCoords procedure} { + list [catch {.c coords x a 2 3 4} msg] $msg +} {1 {bad screen distance "a"}} +test canvRect-3.3 {RectOvalCoords procedure} { + list [catch {.c coords x 1 b 3 4} msg] $msg +} {1 {bad screen distance "b"}} +test canvRect-3.4 {RectOvalCoords procedure} { + list [catch {.c coords x 1 2 c 4} msg] $msg +} {1 {bad screen distance "c"}} +test canvRect-3.5 {RectOvalCoords procedure} { + list [catch {.c coords x 1 2 3 d} msg] $msg +} {1 {bad screen distance "d"}} +test canvRect-3.6 {RectOvalCoords procedure} {nonPortable} { + # Non-portable due to rounding differences. + .c coords x 10 25 15 40 + .c bbox x +} {9 24 16 41} +test canvRect-3.7 {RectOvalCoords procedure} { + list [catch {.c coords x 1 2 3 4 5} msg] $msg +} {1 {wrong # coordinates: expected 0 or 4, got 5}} + +.c delete withtag all +.c create rectangle 10 20 30 40 -tags x -width 1 +test canvRect-4.1 {ConfigureRectOval procedure} { + list [catch {.c itemconfigure x -width abc} msg] $msg \ + [.c itemcget x -width] +} {1 {bad screen distance "abc"} 1} +test canvRect-4.2 {ConfigureRectOval procedure} { + .c itemconfigure x -width -5 + .c itemcget x -width +} {1} +test canvRect-4.3 {ConfigureRectOval procedure} {nonPortable} { + # Non-portable due to rounding differences. + .c itemconfigure x -width 10 + .c bbox x +} {5 15 35 45} +# I can't come up with any good tests for DeleteRectOval. + +.c delete withtag all +.c create rectangle 10 20 30 40 -tags x -width 1 -outline {} +test canvRect-5.1 {ComputeRectOvalBbox procedure} {nonPortable} { + # Non-portable due to rounding differences: + .c coords x 20 15 10 5 + .c bbox x +} {10 5 20 15} +test canvRect-5.2 {ComputeRectOvalBbox procedure} {nonPortable} { + # Non-portable due to rounding differences: + .c coords x 10 20 30 10 + .c itemconfigure x -width 1 -outline red + .c bbox x +} {9 9 31 21} +test canvRect-5.3 {ComputeRectOvalBbox procedure} {nonPortable} { + # Non-portable due to rounding differences: + .c coords x 10 20 30 10 + .c itemconfigure x -width 2 -outline red + .c bbox x +} {9 9 31 21} +test canvRect-5.4 {ComputeRectOvalBbox procedure} {nonPortable} { + # Non-portable due to rounding differences: + .c coords x 10 20 30 10 + .c itemconfigure x -width 3 -outline red + .c bbox x +} {8 8 32 22} + +# I can't come up with any good tests for DisplayRectOval. + +.c delete withtag all +set x [.c create rectangle 10 20 30 35 -tags x -fill green] +set y [.c create rectangle 15 25 25 30 -tags y -fill red] +test canvRect-6.1 {RectToPoint procedure} { + .c itemconfigure y -outline {} + list [.c find closest 14.9 28] [.c find closest 15.1 28] \ + [.c find closest 24.9 28] [.c find closest 25.1 28] +} "$x $y $y $x" +test canvRect-6.2 {RectToPoint procedure} { + .c itemconfigure y -outline {} + list [.c find closest 20 24.9] [.c find closest 20 25.1] \ + [.c find closest 20 29.9] [.c find closest 20 30.1] +} "$x $y $y $x" +test canvRect-6.3 {RectToPoint procedure} { + .c itemconfigure y -width 1 -outline black + list [.c find closest 14.4 28] [.c find closest 14.6 28] \ + [.c find closest 25.4 28] [.c find closest 25.6 28] +} "$x $y $y $x" +test canvRect-6.4 {RectToPoint procedure} { + .c itemconfigure y -width 1 -outline black + list [.c find closest 20 24.4] [.c find closest 20 24.6] \ + [.c find closest 20 30.4] [.c find closest 20 30.6] +} "$x $y $y $x" +.c itemconfigure x -fill {} -outline black -width 3 +.c itemconfigure y -outline {} +test canvRect-6.5 {RectToPoint procedure} { + list [.c find closest 13.2 28] [.c find closest 13.3 28] \ + [.c find closest 26.7 28] [.c find closest 26.8 28] +} "$x $y $y $x" +test canvRect-6.6 {RectToPoint procedure} { + list [.c find closest 20 23.2] [.c find closest 20 23.3] \ + [.c find closest 20 31.7] [.c find closest 20 31.8] +} "$x $y $y $x" +.c delete withtag all +set x [.c create rectangle 10 20 30 40 -outline {} -fill black] +set y [.c create rectangle 40 40 50 50 -outline {} -fill black] +test canvRect-6.7 {RectToPoint procedure} { + list [.c find closest 35 35] [.c find closest 36 36] \ + [.c find closest 37 37] [.c find closest 38 38] +} "$x $y $y $y" + +.c delete withtag all +set x [.c create rectangle 10 20 30 35 -fill green -outline {}] +set y [.c create rectangle 40 45 60 70 -fill red -outline black -width 3] +set z [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3] +test canvRect-7.1 {RectToArea procedure} { + list [.c find overlapping 20 50 38 60] \ + [.c find overlapping 20 50 39 60] \ + [.c find overlapping 20 50 70 60] \ + [.c find overlapping 61 50 70 60] \ + [.c find overlapping 62 50 70 60] +} "{} $y $y $y {}" +test canvRect-7.2 {RectToArea procedure} { + list [.c find overlapping 45 20 55 43] \ + [.c find overlapping 45 20 55 44] \ + [.c find overlapping 45 20 55 80] \ + [.c find overlapping 45 71 55 80] \ + [.c find overlapping 45 72 55 80] +} "{} $y $y $y {}" +test canvRect-7.3 {RectToArea procedure} { + list [.c find overlapping 5 25 9.9 30] [.c find overlapping 5 25 10.1 30] +} "{} $x" +test canvRect-7.4 {RectToArea procedure} { + list [.c find overlapping 102 152 118 168] \ + [.c find overlapping 101 152 118 168] \ + [.c find overlapping 102 151 118 168] \ + [.c find overlapping 102 152 119 168] \ + [.c find overlapping 102 152 118 169] +} "{} $z $z $z $z" +test canvRect-7.5 {RectToArea procedure} { + list [.c find enclosed 20 40 38 80] \ + [.c find enclosed 20 40 39 80] \ + [.c find enclosed 20 40 70 80] \ + [.c find enclosed 61 40 70 80] \ + [.c find enclosed 62 40 70 80] +} "{} {} $y {} {}" +test canvRect-7.6 {RectToArea procedure} { + list [.c find enclosed 20 20 65 43] \ + [.c find enclosed 20 20 65 44] \ + [.c find enclosed 20 20 65 80] \ + [.c find enclosed 20 71 65 80] \ + [.c find enclosed 20 72 65 80] +} "{} {} $y {} {}" + +.c delete withtag all +set x [.c create oval 50 100 200 150 -fill green -outline {}] +set y [.c create oval 50 100 200 150 -fill red -outline black -width 3] +set z [.c create oval 50 100 200 150 -fill {} -outline black -width 3] +test canvRect-8.1 {OvalToArea procedure} { + list [.c find overlapping 20 120 48 130] \ + [.c find overlapping 20 120 49 130] \ + [.c find overlapping 20 120 50.2 130] \ + [.c find overlapping 20 120 300 130] \ + [.c find overlapping 60 120 190 130] \ + [.c find overlapping 199.9 120 300 130] \ + [.c find overlapping 201 120 300 130] \ + [.c find overlapping 202 120 300 130] +} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}" +test canvRect-8.2 {OvalToArea procedure} { + list [.c find overlapping 100 50 150 98] \ + [.c find overlapping 100 50 150 99] \ + [.c find overlapping 100 50 150 100.1] \ + [.c find overlapping 100 50 150 200] \ + [.c find overlapping 100 110 150 140] \ + [.c find overlapping 100 149.9 150 200] \ + [.c find overlapping 100 151 150 200] \ + [.c find overlapping 100 152 150 200] +} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}" +test canvRect-8.3 {OvalToArea procedure} { + list [.c find overlapping 176 104 177 105] \ + [.c find overlapping 187 116 188 117] \ + [.c find overlapping 192 142 193 143] \ + [.c find overlapping 180 138 181 139] \ + [.c find overlapping 61 142 62 143] \ + [.c find overlapping 65 137 66 136] \ + [.c find overlapping 62 108 63 109] \ + [.c find overlapping 68 115 69 116] +} "{} {$x $y} {} {$x $y} {} {$x $y} {} {$x $y}" + +test canvRect-9.1 {ScaleRectOval procedure} { + .c delete withtag all + .c create rect 100 300 200 350 -tags x + .c scale x 50 100 2 4 + .c coords x +} {150.0 900.0 350.0 1100.0} + +test canvRect-10.1 {TranslateRectOval procedure} { + .c delete withtag all + .c create rect 100 300 200 350 -tags x + .c move x 100 -10 + .c coords x +} {200.0 290.0 300.0 340.0} + +# This test is non-portable because different color information +# will get generated on different displays (e.g. mono displays +# vs. color). +test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable win32sCrash macCrash} { + # Crashes on Mac because the XGetImage() call isn't implemented, causing a + # dereference of NULL. + + .c configure -bd 0 -highlightthickness 0 + .c delete withtag all + .c create rect 50 60 90 80 -fill black -stipple gray50 -outline {} + .c create oval 100 150 200 200 -fill {} -outline #ff0000 -width 5 + update + set x [.c postscript] + string range $x [string first "-200 -150 translate" $x] end +} {-200 -150 translate +0 300 moveto 400 300 lineto 400 0 lineto 0 0 lineto closepath clip newpath +gsave +50 240 moveto 40 0 rlineto 0 -20 rlineto -40 0 rlineto closepath +0.000 0.000 0.000 setrgbcolor AdjustColor +clip 16 16 <5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555 +aaaa> StippleFill +grestore +gsave +matrix currentmatrix +150 125 translate 50 25 scale 1 0 moveto 0 0 1 0 360 arc +setmatrix +5 setlinewidth 0 setlinejoin 2 setlinecap +1.000 0.000 0.000 setrgbcolor AdjustColor +stroke +grestore +restore showpage + +%%Trailer +end +%%EOF +} diff --git a/tests/canvText.test b/tests/canvText.test new file mode 100644 index 0000000..b121c25 --- /dev/null +++ b/tests/canvText.test @@ -0,0 +1,492 @@ +# This file is a Tcl script to test out the procedures in tkCanvText.c, +# which implement canvas "text" items. It is organized in the standard +# fashion for Tcl tests. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) canvText.test 1.8 97/06/24 13:34:16 + +if {"[info procs test]" != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +canvas .c -width 400 -height 300 -bd 2 -relief sunken +pack .c +update + +set i 1 +.c create text 20 20 -tag test + +set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" +set ay [font metrics $font -linespace] +set ax [font measure $font 0] + + +foreach test { + {-anchor nw nw xyz {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}} + {-fill #ff0000 #ff0000 xyz {unknown color name "xyz"}} + {-font {Times 40} {Times 40} {} {font "" doesn't exist}} + {-justify left left xyz {bad justification "xyz": must be left, right, or center}} + {-stipple gray50 gray50 xyz {bitmap "xyz" not defined}} + {-tags {test a b c} {test a b c} {} {}} + {-text xyz xyz {} {}} + {-width 6 6 xyz {bad screen distance "xyz"}} +} { + set name [lindex $test 0] + test canvText-1.$i {configuration options} { + .c itemconfigure test $name [lindex $test 1] + list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name] + } [list [lindex $test 2] [lindex $test 2]] + 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]] + } + incr i +} +test canvText-1.$i {configuration options} { + .c itemconfigure test -tags {test xyz} + .c itemcget xyz -tags +} {test xyz} + +.c delete test +.c create text 20 20 -tag test + +test canvText-2.1 {CreateText procedure: args} { + list [catch {.c create text} msg] $msg +} {1 {wrong # args: should be ".c create text x y ?options?"}} +test canvText-2.2 {CreateText procedure: args} { + list [catch {.c create text xyz 0} msg] $msg +} {1 {bad screen distance "xyz"}} +test canvText-2.3 {CreateText procedure: args} { + list [catch {.c create text 0 xyz} msg] $msg +} {1 {bad screen distance "xyz"}} +test canvText-2.4 {CreateText procedure: args} { + list [catch {.c create text 0 0 -xyz xyz} msg] $msg +} {1 {unknown option "-xyz"}} +test canvText-2.5 {CreateText procedure} { + .c create text 0 0 -tags x + set x [.c coords x] + .c delete x + set x +} {0.0 0.0} + +focus -force .c +.c focus test +.c coords test 0 0 +update + +test canvText-3.1 {TextCoords procedure} { + .c coords test +} {0.0 0.0} +test canvText-3.2 {TextCoords procedure} { + list [catch {.c coords test xyz 0} msg] $msg +} {1 {bad screen distance "xyz"}} +test canvText-3.3 {TextCoords procedure} { + list [catch {.c coords test 0 xyz} msg] $msg +} {1 {bad screen distance "xyz"}} +test canvText-3.4 {TextCoords procedure} { + .c coords test 10 10 + set result {} + foreach element [.c coords test] { + lappend result [format %.1f $element] + } + set result +} {10.0 10.0} +test canvText-3.5 {TextCoords procedure} { + list [catch {.c coords test 10} msg] $msg +} {1 {wrong # coordinates: expected 0 or 2, got 1}} +test canvText-3.6 {TextCoords procedure} { + list [catch {.c coords test 10 10 10} msg] $msg +} {1 {wrong # coordinates: expected 0 or 2, got 3}} + +test canvText-4.1 {ConfigureText procedure} { + list [catch {.c itemconfig test -fill xyz} msg] $msg +} {1 {unknown color name "xyz"}} +test canvText-4.2 {ConfigureText procedure} { + .c itemconfig test -fill blue + .c itemcget test -fill +} {blue} +test canvText-4.3 {ConfigureText procedure: construct font gcs} { + .c itemconfig test -font "times 20" -fill black -stipple gray50 + list [.c itemcget test -font] [.c itemcget test -fill] [.c itemcget test -stipple] +} {{times 20} black gray50} +test canvText-4.4 {ConfigureText procedure: construct cursor gc} { + .c itemconfig test -text "abcdefg" + .c select from test 2 + .c select to test 4 + .c icursor test 3 + + # Both black -> cursor becomes white. + .c config -insertbackground black + .c config -selectbackground black + .c itemconfig test -just left + update + + # Both same color (and not black) -> cursor becomes black. + .c config -insertbackground red + .c config -selectbackground red + .c itemconfig test -just left + update +} {} +test canvText-4.5 {ConfigureText procedure: adjust selection} { + set x {} + .c itemconfig test -text "abcdefghi" + .c select from test 2 + .c select to test 6 + lappend x [selection get] + .c dchars test 1 end + lappend x [catch {selection get}] + .c insert test end "bcdefghi" + .c select from test 2 + .c select to test 6 + lappend x [selection get] + .c dchars test 4 end + lappend x [selection get] + .c insert test end "efghi" + .c select from test 6 + .c select to test 2 + lappend x [selection get] + .c dchars test 4 end + lappend x [selection get] +} {cdefg 1 cdefg cd cdef cd} +test canvText-4.6 {ConfigureText procedure: adjust cursor} { + .c itemconfig test -text "abcdefghi" + set x {} + .c icursor test 6 + .c dchars test 4 end + .c index test insert +} {4} + +test canvText-5.1 {ConfigureText procedure: adjust cursor} { + .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 -text "xyz" + .c delete x +} {} + +test canvText-6.1 {ComputeTextBbox procedure} {fonts} { + .c itemconfig test -font $font -text 0 + .c coords test 0 0 + set x {} + lappend x [.c itemconfig test -anchor n; .c bbox test] + lappend x [.c itemconfig test -anchor nw; .c bbox test] + lappend x [.c itemconfig test -anchor w; .c bbox test] + lappend x [.c itemconfig test -anchor sw; .c bbox test] + lappend x [.c itemconfig test -anchor s; .c bbox test] + lappend x [.c itemconfig test -anchor se; .c bbox test] + lappend x [.c itemconfig test -anchor e; .c bbox test] + lappend x [.c itemconfig test -anchor ne; .c bbox test] + lappend x [.c itemconfig test -anchor center; .c bbox test] +} "{[expr -$ax/2-1] 0 [expr $ax/2+1] $ay}\ +{-1 0 [expr $ax+1] $ay}\ +{-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]}\ +{-1 -$ay [expr $ax+1] 0}\ +{[expr -$ax/2-1] -$ay [expr $ax/2+1] 0}\ +{[expr -$ax-1] -$ay 1 0}\ +{[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]}\ +{[expr -$ax-1] 0 1 $ay}\ +{[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]}" + +focus .c +.c focus test +.c itemconfig test -text "abcd\nefghi\njklmnopq" +test canvText-7.1 {DisplayText procedure: stippling} { + .c itemconfig test -stipple gray50 + update + .c itemconfig test -stipple {} + update +} {} +test canvText-7.2 {DisplayText procedure: draw selection} { + .c select from test 0 + .c select to test end + update + selection get +} "abcd\nefghi\njklmnopq" +test canvText-7.3 {DisplayText procedure: selection} { + .c select from test 0 + .c select to test end + update + selection get +} "abcd\nefghi\njklmnopq" +test canvText-7.4 {DisplayText procedure: one line selection} { + .c select from test 2 + .c select to test 3 + update +} {} +test canvText-7.5 {DisplayText procedure: multi-line selection} { + .c select from test 2 + .c select to test 12 + update +} {} +test canvText-7.6 {DisplayText procedure: draw cursor} { + .c icursor test 3 + update +} {} +test canvText-7.7 {DisplayText procedure: selected text different color} { + .c config -selectforeground blue + .c itemconfig test -anchor n + update +} {} +test canvText-7.8 {DisplayText procedure: not selected} { + .c select clear + update +} {} + +test canvText-8.1 {TextInsert procedure: 0 length insert} { + .c insert test end {} +} {} +test canvText-8.2 {TextInsert procedure: before beginning/after end} { + # Can't test this because GetTextIndex filters out those numbers. +} {} +test canvText-8.3 {TextInsert procedure: inserting in a selected item} { + .c itemconfig test -text "abcdefg" + .c select from test 2 + .c select to test 4 + .c insert test 1 "xyz" + .c itemcget test -text +} {axyzbcdefg} +test canvText-8.4 {TextInsert procedure: inserting before selection} { + .c itemconfig test -text "abcdefg" + .c select from test 2 + .c select to test 4 + .c insert test 1 "xyz" + list [.c index test sel.first] [.c index test sel.last] +} {5 7} +test canvText-8.5 {TextInsert procedure: inserting in selection} { + .c itemconfig test -text "abcdefg" + .c select from test 2 + .c select to test 4 + .c insert test 3 "xyz" + list [.c index test sel.first] [.c index test sel.last] +} {2 7} +test canvText-8.6 {TextInsert procedure: inserting after selection} { + .c itemconfig test -text "abcdefg" + .c select from test 2 + .c select to test 4 + .c insert test 5 "xyz" + list [.c index test sel.first] [.c index test sel.last] +} {2 4} +test canvText-8.7 {TextInsert procedure: inserting in unselected item} { + .c itemconfig test -text "abcdefg" + .c select clear + .c insert test 5 "xyz" + .c itemcget test -text +} {abcdexyzfg} +test canvText-8.8 {TextInsert procedure: inserting before cursor} { + .c itemconfig test -text "abcdefg" + .c icursor test 3 + .c insert test 2 "xyz" + .c index test insert +} {6} +test canvText-8.9 {TextInsert procedure: inserting after cursor} { + .c itemconfig test -text "abcdefg" + .c icursor test 3 + .c insert test 4 "xyz" + .c index test insert +} {3} + +test canvText-9.1 {TextInsert procedure: before beginning/after end} { + # Can't test this because GetTextIndex filters out those numbers. +} {} +test canvText-9.2 {TextInsert procedure: start > end} { + .c itemconfig test -text "abcdefg" + .c dchars test 4 2 + .c itemcget test -text +} {abcdefg} +test canvText-9.3 {TextInsert procedure: deleting from a selected item} { + .c itemconfig test -text "abcdefg" + .c select from test 2 + .c select to test 4 + .c dchars test 3 5 + .c itemcget test -text +} {abcg} +test canvText-9.4 {TextInsert procedure: deleting before start} { + .c itemconfig test -text "abcdefghijk" + .c select from test 4 + .c select to test 8 + .c dchars test 1 1 + list [.c index test sel.first] [.c index test sel.last] +} {3 7} +test canvText-9.5 {TextInsert procedure: keep start > first char deleted} { + .c itemconfig test -text "abcdefghijk" + .c select from test 4 + .c select to test 8 + .c dchars test 2 6 + list [.c index test sel.first] [.c index test sel.last] +} {2 3} +test canvText-9.6 {TextInsert procedure: deleting inside selection} { + .c itemconfig test -text "abcdefghijk" + .c select from test 4 + .c select to test 8 + .c dchars test 6 6 + list [.c index test sel.first] [.c index test sel.last] +} {4 7} +test canvText-9.7 {TextInsert procedure: keep end > first char deleted} { + .c itemconfig test -text "abcdefghijk" + .c select from test 4 + .c select to test 8 + .c dchars test 6 10 + list [.c index test sel.first] [.c index test sel.last] +} {4 5} +test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} { + .c itemconfig test -text "abcdefghijk" + .c select from test 4 + .c select to test 8 + .c dchars test 3 10 + list [catch {.c index test sel.first} msg] $msg +} {1 {selection isn't in item}} +test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} { + .c itemconfig test -text "abcdefghijk" + .c select from test 4 + .c select to test 8 + .c dchars test 4 7 + list [.c index test sel.first] [.c index test sel.last] +} {4 4} +test canvText-9.10 {TextInsert procedure: move anchor} { + .c itemconfig test -text "abcdefghijk" + .c select from test 6 + .c select to test 8 + .c dchars test 2 4 + .c select to test 1 + list [.c index test sel.first] [.c index test sel.last] +} {1 2} +test canvText-9.11 {TextInsert procedure: keep anchor >= first} { + .c itemconfig test -text "abcdefghijk" + .c select from test 6 + .c select to test 8 + .c dchars test 5 7 + .c select to test 1 + list [.c index test sel.first] [.c index test sel.last] +} {1 4} +test canvText-9.12 {TextInsert procedure: anchor doesn't move} { + .c itemconfig test -text "abcdefghijk" + .c select from test 2 + .c select to test 5 + .c dchars test 6 8 + .c select to test 8 + list [.c index test sel.first] [.c index test sel.last] +} {2 8} +test canvText-9.13 {TextInsert procedure: move cursor} { + .c itemconfig test -text "abcdefghijk" + .c icursor test 6 + .c dchars test 2 4 + .c index test insert +} {3} +test canvText-9.14 {TextInsert procedure: keep cursor >= first} { + .c itemconfig test -text "abcdefghijk" + .c icursor test 6 + .c dchars test 2 10 + .c index test insert +} {2} +test canvText-9.15 {TextInsert procedure: cursor doesn't move} { + .c itemconfig test -text "abcdefghijk" + .c icursor test 5 + .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 + .c index test @0,0 +} {0} + +test canvText-11.1 {TextToArea procedure} { + .c coords test 0 0 + .c itemconfig test -text 0 -anchor center + .c find overlapping 0 0 1 1 +} [.c find withtag test] +test canvText-11.2 {TextToArea procedure} { + .c coords test 0 0 + .c itemconfig test -text 0 -anchor center + .c find overlapping 1000 1000 1001 1001 +} {} + +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} + +test canvText-13.1 {TranslateText procedure} { + .c coords test 100 100 + .c move all 10 10 + .c coords test +} {110.0 110.0} + +.c itemconfig test -text "abcdefghijklmno" -anchor nw +.c select from test 5 +.c select to test 8 +.c icursor test 12 +.c coords test 0 0 +test canvText-14.1 {GetTextIndex procedure} { + list [.c index test end] [.c index test insert] \ + [.c index test sel.first] [.c index test sel.last] \ + [.c index test @0,0] \ + [.c index test -1] [.c index test 10] [.c index test 100] +} {15 12 5 8 0 0 10 15} +test canvText-14.2 {GetTextIndex procedure: select error} { + .c select clear + list [catch {.c index test sel.first} msg] $msg +} {1 {selection isn't in item}} +test canvText-14.3 {GetTextIndex procedure: select error} { + .c select clear + list [catch {.c index test sel.last} msg] $msg +} {1 {selection isn't in item}} +test canvText-14.4 {GetTextIndex procedure: select error} { + .c select clear + list [catch {.c index test sel.} msg] $msg +} {1 {bad index "sel."}} +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-15.1 {SetTextCursor procedure} { + .c itemconfig -text "abcdefg" + .c icursor test 3 + .c index test insert +} {3} + +test canvText-16.1 {GetSelText procedure} { + .c itemconfig test -text "abcdefghijklmno" -anchor nw + .c select from test 5 + .c select to test 8 + selection get +} {fghi} + +set font {Courier 12 italic} +set ax [font measure $font 0] +set ay [font metrics $font -linespace] + +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 itemconfig test -font $font -text "00000000" -width [expr 3*$ax] + .c itemconfig test -anchor n -fill black + set x [.c postscript] + set x [string range $x [string first "/Courier-Oblique" $x] end] +} "/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont +0.000 0.000 0.000 setrgbcolor AdjustColor +100 200 \[ +(000) +(000) +(00) +] $ay -0.5 0 0 false DrawText +grestore +restore showpage + +%%Trailer +end +%%EOF +" diff --git a/tests/canvWind.test b/tests/canvWind.test new file mode 100644 index 0000000..d8c6835 --- /dev/null +++ b/tests/canvWind.test @@ -0,0 +1,133 @@ +# This file is a Tcl script to test out the procedures in tkCanvWind.c, +# which implement canvas "window" items. It is organized in the standard +# fashion for Tcl tests. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) canvWind.test 1.2 97/11/06 13:49:14 + +if {"[info procs test]" != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} { + catch {destroy .t} + toplevel .t + canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ + -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ + -highlightthickness 1 + pack .t.c -fill both -expand 1 -padx 20 -pady 20 + wm geometry .t +0+0 + set f .t.f + frame $f -width 80 -height 50 -bg red + .t.c create window 300 400 -window $f -anchor nw + .t.c xview moveto .3 + .t.c yview moveto .50 + update + set x [list [list [winfo ismapped $f] [winfo y $f]]] + .t.c yview scroll 52 units + update + lappend x [list [winfo ismapped $f] [winfo y $f]] + .t.c yview scroll 1 units + update + lappend x [list [winfo ismapped $f] [winfo y $f]] + .t.c yview scroll -255 units + update + lappend x [list [winfo ismapped $f] [winfo y $f]] + .t.c yview scroll -1 units + update + lappend x [list [winfo ismapped $f] [winfo y $f]] +} {{1 23} {1 -29} {0 -29} {1 225} {0 225}} +test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} { + catch {destroy .t} + toplevel .t + canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ + -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ + -highlightthickness 1 + pack .t.c -fill both -expand 1 -padx 20 -pady 20 + wm geometry .t +0+0 + set f .t.c.f + frame $f -width 80 -height 50 -bg red + .t.c create window 300 400 -window $f -anchor nw + .t.c xview moveto .3 + .t.c yview moveto .50 + update + set x [list [list [winfo ismapped $f] [winfo y $f]]] + .t.c yview scroll 52 units + update + lappend x [list [winfo ismapped $f] [winfo y $f]] + .t.c yview scroll 1 units + update + lappend x [list [winfo ismapped $f] [winfo y $f]] + .t.c yview scroll -255 units + update + lappend x [list [winfo ismapped $f] [winfo y $f]] + .t.c yview scroll -1 units + update + lappend x [list [winfo ismapped $f] [winfo y $f]] +} {{1 3} {1 -49} {0 -49} {1 205} {0 205}} +test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} { + catch {destroy .t} + toplevel .t + canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ + -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ + -highlightthickness 1 + pack .t.c -fill both -expand 1 -padx 20 -pady 20 + wm geometry .t +0+0 + set f .t.f + frame $f -width 80 -height 50 -bg red + .t.c create window 300 400 -window $f -anchor nw + .t.c xview moveto .3 + .t.c yview moveto .50 + update + set x [list [list [winfo ismapped $f] [winfo x $f]]] + .t.c xview scroll 82 units + update + lappend x [list [winfo ismapped $f] [winfo x $f]] + .t.c xview scroll 1 units + update + lappend x [list [winfo ismapped $f] [winfo x $f]] + .t.c xview scroll -335 units + update + lappend x [list [winfo ismapped $f] [winfo x $f]] + .t.c xview scroll -1 units + update + lappend x [list [winfo ismapped $f] [winfo x $f]] +} {{1 23} {1 -59} {0 -59} {1 275} {0 275}} +test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} { + catch {destroy .t} + toplevel .t + canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ + -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ + -highlightthickness 1 + pack .t.c -fill both -expand 1 -padx 20 -pady 20 + wm geometry .t +0+0 + set f .t.c.f + frame $f -width 80 -height 50 -bg red + .t.c create window 300 400 -window $f -anchor nw + .t.c xview moveto .3 + .t.c yview moveto .50 + update + set x [list [list [winfo ismapped $f] [winfo x $f]]] + .t.c xview scroll 82 units + update + lappend x [list [winfo ismapped $f] [winfo x $f]] + .t.c xview scroll 1 units + update + lappend x [list [winfo ismapped $f] [winfo x $f]] + .t.c xview scroll -335 units + update + lappend x [list [winfo ismapped $f] [winfo x $f]] + .t.c xview scroll -1 units + update + lappend x [list [winfo ismapped $f] [winfo x $f]] +} {{1 3} {1 -79} {0 -79} {1 255} {0 255}} diff --git a/tests/canvas.test b/tests/canvas.test new file mode 100644 index 0000000..786a29a --- /dev/null +++ b/tests/canvas.test @@ -0,0 +1,192 @@ +# This file is a Tcl script to test out the procedures in tkCanvas.c, +# which implements generic code for canvases. It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) canvas.test 1.10 97/07/31 10:22:48 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# XXX - This test file is woefully incomplete. At present, only a +# few of the features are tested. + +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} {} {}} +} { + set name [lindex $test 0] + test canvas-1.$i {configuration options} { + .c configure $name [lindex $test 1] + lindex [.c configure $name] 4 + } [lindex $test 2] + 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]] + } + .c configure $name [lindex [.c configure $name] 3] + incr i +} + + +catch {destroy .c} +canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \ + -highlightthickness 0 +pack .c +update +test canvas-2.1 {CanvasWidgetCmd, xview option} { + .c configure -xscrollincrement 40 -yscrollincrement 5 + .c xview moveto 0 + update + set x [list [.c xview]] + .c xview scroll 2 units + update + lappend x [.c xview] +} {{0 0.3} {0.4 0.7}} +test canvas-2.2 {CanvasWidgetCmd, xview option} {nonPortable} { + # This test gives slightly different results on platforms such + # as NetBSD. I don't know why... + .c configure -xscrollincrement 0 -yscrollincrement 5 + .c xview moveto 0.6 + update + set x [list [.c xview]] + .c xview scroll 2 units + update + lappend x [.c xview] +} {{0.6 0.9} {0.66 0.96}} + +catch {destroy .c} +canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \ + -borderwidth 0 -highlightthickness 0 +pack .c +update +test canvas-3.1 {CanvasWidgetCmd, yview option} { + .c configure -xscrollincrement 40 -yscrollincrement 5 + .c yview moveto 0 + update + set x [list [.c yview]] + .c yview scroll 3 units + update + lappend x [.c yview] +} {{0 0.5} {0.1875 0.6875}} +test canvas-3.2 {CanvasWidgetCmd, yview option} { + .c configure -xscrollincrement 40 -yscrollincrement 0 + .c yview moveto 0 + update + set x [list [.c yview]] + .c yview scroll 2 units + update + lappend x [.c yview] +} {{0 0.5} {0.1 0.6}} + +test canvas-4.1 {ButtonEventProc procedure} { + eval destroy [winfo children .] + canvas .c1 -bg #543210 + rename .c1 .c2 + set x {} + lappend x [winfo children .] + lappend x [.c2 cget -bg] + destroy .c1 + lappend x [info command .c*] [winfo children .] +} {.c1 #543210 {} {}} + +test canvas-5.1 {ButtonCmdDeletedProc procedure} { + eval destroy [winfo children .] + canvas .c1 + rename .c1 {} + list [info command .c*] [winfo children .] +} {{} {}} + +catch {destroy .c} +canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \ + -borderwidth 2 -highlightthickness 3 +pack .c +update +test canvas-6.1 {CanvasSetOrigin procedure} { + .c configure -xscrollincrement 0 -yscrollincrement 0 + .c xview moveto 0 + .c yview moveto 0 + update + list [.c canvasx 0] [.c canvasy 0] +} {-205.0 -105.0} +test canvas-6.2 {CanvasSetOrigin procedure} { + .c configure -xscrollincrement 20 -yscrollincrement 10 + set x "" + foreach i {.08 .10 .48 .50} { + .c xview moveto $i + update + lappend x [.c canvasx 0] + } + set x +} {-165.0 -145.0 35.0 55.0} +test canvas-6.3 {CanvasSetOrigin procedure} { + .c configure -xscrollincrement 20 -yscrollincrement 10 + set x "" + foreach i {.06 .08 .70 .72} { + .c yview moveto $i + update + lappend x [.c canvasy 0] + } + set x +} {-95.0 -85.0 35.0 45.0} +test canvas-6.4 {CanvasSetOrigin procedure} { + .c configure -xscrollincrement 20 -yscrollincrement 10 + .c xview moveto 1.0 + .c canvasx 0 +} {215.0} +test canvas-6.5 {CanvasSetOrigin procedure} { + .c configure -xscrollincrement 20 -yscrollincrement 10 + .c yview moveto 1.0 + .c canvasy 0 +} {55.0} + +set l [interp hidden] +eval destroy [winfo children .] + +test canvas-7.1 {canvas widget vs hidden commands} { + catch {destroy .c} + canvas .c + interp hide {} .c + destroy .c + list [winfo children .] [interp hidden] +} [list {} $l] diff --git a/tests/clipboard.test b/tests/clipboard.test new file mode 100644 index 0000000..90f4ecb --- /dev/null +++ b/tests/clipboard.test @@ -0,0 +1,234 @@ +# This file is a Tcl script to test out Tk's clipboard management code, +# especially the "clipboard" command. It is organized in the standard +# fashion for Tcl tests. +# +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) clipboard.test 1.15 96/12/09 17:26:02 + +# +# Note: Multiple display clipboard handling will only be tested if the +# environment variable TK_ALT_DISPLAY is set to an alternate display. +# + +if {[string compare test [info procs test]] == 1} { + source defs +} + +eval destroy [winfo child .] + +# set up a very large buffer to test INCR retrievals +set longValue "" +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} { + set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14 + 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 +} + +# Now we start the main body of the test code + +test clipboard-1.1 {ClipboardHandler procedure} { + clipboard clear + clipboard append "test" + selection get -s CLIPBOARD +} {test} +test clipboard-1.2 {ClipboardHandler procedure} { + clipboard clear + clipboard append "test" + clipboard append "ing" + selection get -s CLIPBOARD +} {testing} +test clipboard-1.3 {ClipboardHandler procedure} { + clipboard clear + clipboard append "t" + clipboard append "e" + clipboard append "s" + clipboard append "t" + selection get -s CLIPBOARD +} {test} +test clipboard-1.4 {ClipboardHandler procedure} { + clipboard clear + clipboard append $longValue + selection get -s CLIPBOARD +} "$longValue" +test clipboard-1.5 {ClipboardHandler procedure} { + clipboard clear + clipboard append $longValue + clipboard append "test" + selection get -s CLIPBOARD +} "${longValue}test" +test clipboard-1.6 {ClipboardHandler procedure} { + clipboard clear + clipboard append -t TEST $longValue + clipboard append -t STRING "test" + list [selection get -s CLIPBOARD -t STRING] \ + [selection get -s CLIPBOARD -t TEST] +} [list test $longValue] +test clipboard-1.7 {ClipboardHandler procedure} { + clipboard clear + clipboard append -t TEST [string range $longValue 1 4000] + clipboard append -t STRING "test" + list [selection get -s CLIPBOARD -t STRING] \ + [selection get -s CLIPBOARD -t TEST] +} [list test [string range $longValue 1 4000]] +test clipboard-1.8 {ClipboardHandler procedure} { + clipboard clear + clipboard append "" + selection get -s CLIPBOARD +} {} +test clipboard-1.9 {ClipboardHandler procedure} { + clipboard clear + clipboard append "" + clipboard append "Test" + selection get -s CLIPBOARD +} {Test} + +############################################################################## + +test clipboard-2.1 {ClipboardAppHandler procedure} { + set oldAppName [tk appname] + tk appname UnexpectedName + clipboard clear + clipboard append -type NEW_TYPE Data + set result [selection get -selection CLIPBOARD -type TK_APPLICATION] + tk appname $oldAppName + set result +} {UnexpectedName} + +############################################################################## + +test clipboard-3.1 {ClipboardWindowHandler procedure} { + set oldAppName [tk appname] + tk appname UnexpectedName + clipboard clear + clipboard append -type NEW_TYPE Data + set result [selection get -selection CLIPBOARD -type TK_WINDOW] + tk appname $oldAppName + set result +} {.} + +############################################################################## + +test clipboard-4.1 {ClipboardLostSel procedure} { + clipboard clear + clipboard append "Test" + selection clear -s CLIPBOARD + list [catch {selection get -s CLIPBOARD} msg] $msg +} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined}} +test clipboard-4.2 {ClipboardLostSel procedure} { + clipboard clear + clipboard append "Test" + clipboard append -t TEST "Test2" + selection clear -s CLIPBOARD + list [catch {selection get -s CLIPBOARD} msg] $msg \ + [catch {selection get -s CLIPBOARD -t TEST} msg] $msg +} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined} 1 {CLIPBOARD selection doesn't exist or form "TEST" not defined}} +test clipboard-4.3 {ClipboardLostSel procedure} { + clipboard clear + clipboard append "Test" + clipboard append -t TEST "Test2" + clipboard append "Test3" + selection clear -s CLIPBOARD + list [catch {selection get -s CLIPBOARD} msg] $msg \ + [catch {selection get -s CLIPBOARD -t TEST} msg] $msg +} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined} 1 {CLIPBOARD selection doesn't exist or form "TEST" not defined}} + +############################################################################## + +test clipboard-5.1 {Tk_ClipboardClear procedure} { + clipboard clear + clipboard append -t TEST "test" + set result [lsort [selection get -s CLIPBOARD TARGETS]] + clipboard clear + list $result [lsort [selection get -s CLIPBOARD TARGETS]] +} {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} +test clipboard-5.2 {Tk_ClipboardClear procedure} { + clipboard clear + clipboard append -t TEST "test" + set result [lsort [selection get -s CLIPBOARD TARGETS]] + selection own -s CLIPBOARD . + lappend result [lsort [selection get -s CLIPBOARD TARGETS]] + clipboard clear + clipboard append -t TEST "test" + lappend result [lsort [selection get -s CLIPBOARD TARGETS]] +} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} + +############################################################################## + +test clipboard-6.1 {Tk_ClipboardAppend procedure} { + clipboard clear + clipboard append "first chunk" + selection own -s CLIPBOARD . + list [catch { + clipboard append " second chunk" + selection get -s CLIPBOARD + } msg] $msg +} {0 {first chunk second chunk}} +test clipboard-6.2 {Tk_ClipboardAppend procedure} {unixOnly} { + setupbg + clipboard clear + clipboard append -f INTEGER -t TEST "16" + set result [dobg {selection get -s CLIPBOARD TEST}] + cleanupbg + set result +} {0x10} +test clipboard-6.3 {Tk_ClipboardAppend procedure} { + clipboard clear + clipboard append -f INTEGER -t TEST "16" + list [catch {clipboard append -t TEST "test"} msg] $msg +} {1 {format "STRING" does not match current format "INTEGER" for TEST}} + +############################################################################## + +test clipboard-7.1 {Tk_ClipboardCmd procedure} { + list [catch {clipboard} msg] $msg +} {1 {wrong # args: should be "clipboard option ?arg arg ...?"}} +test clipboard-7.2 {Tk_ClipboardCmd procedure} { + clipboard clear + list [catch {clipboard append --} msg] $msg \ + [selection get -selection CLIPBOARD] +} {0 {} --} +test clipboard-7.3 {Tk_ClipboardCmd procedure} { + clipboard clear + list [catch {clipboard append -- information} msg] $msg \ + [selection get -selection CLIPBOARD] +} {0 {} information} +test clipboard-7.4 {Tk_ClipboardCmd procedure} { + list [catch {clipboard append --x a b} msg] $msg +} {1 {unknown option "--x"}} +test clipboard-7.5 {Tk_ClipboardCmd procedure} { + list [catch {clipboard append -- a b} msg] $msg +} {1 {wrong # args: should be "clipboard append ?options? data"}} +test clipboard-7.6 {Tk_ClipboardCmd procedure} { + clipboard clear + list [catch {clipboard append -format} msg] $msg \ + [selection get -selection CLIPBOARD] +} {0 {} -format} +test clipboard-7.7 {Tk_ClipboardCmd procedure} { + list [catch {clipboard append -displayofoo f} msg] $msg +} {1 {unknown option "-displayofoo"}} +test clipboard-7.8 {Tk_ClipboardCmd procedure} { + list [catch {clipboard append -type TEST} msg] $msg +} {1 {wrong # args: should be "clipboard append ?options? data"}} +test clipboard-7.9 {Tk_ClipboardCmd procedure} { + list [catch {clipboard append -displayof foo "test"} msg] $msg +} {1 {bad window path name "foo"}} + +test clipboard-7.10 {Tk_ClipboardCmd procedure} { + list [catch {clipboard clear -displayof} msg] $msg +} {1 {value for "-displayof" missing}} +test clipboard-7.11 {Tk_ClipboardCmd procedure} { + list [catch {clipboard clear -displayofoo f} msg] $msg +} {1 {unknown option "-displayofoo"}} +test clipboard-7.12 {Tk_ClipboardCmd procedure} { + list [catch {clipboard clear foo} msg] $msg +} {1 {wrong # args: should be "clipboard clear ?options?"}} +test clipboard-7.13 {Tk_ClipboardCmd procedure} { + list [catch {clipboard clear -displayof foo} msg] $msg +} {1 {bad window path name "foo"}} + +test clipboard-7.14 {Tk_ClipboardCmd procedure} { + list [catch {clipboard error} msg] $msg +} {1 {bad option "error": must be clear or append}} diff --git a/tests/clrpick.test b/tests/clrpick.test new file mode 100644 index 0000000..d267224 --- /dev/null +++ b/tests/clrpick.test @@ -0,0 +1,215 @@ +# This file is a Tcl script to test out Tk's "tk_chooseColor" command. +# It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) clrpick.test 1.9 97/10/21 11:29:53 +# + +if {[string compare test [info procs test]] == 1} { + source defs +} + +test clrpick-1.1 {tk_chooseColor command} { + list [catch {tk_chooseColor -foo} msg] $msg +} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}} + +catch {tk_chooseColor -foo} msg +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"] + } +} + +test clrpick-1.3 {tk_chooseColor command} { + list [catch {tk_chooseColor -foo bar} msg] $msg +} {1 {unknown 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 tkColorDialog] == ""} { + set isNative 1 +} else { + set isNative 0 +} + +if {$isNative && ![info exists INTERACTIVE]} { + puts " Some tests were skipped because they could not be performed" + puts " automatically on this platform. If you wish to execute them" + puts " interactively, set the TCL variable INTERACTIVE and re-run" + puts " the test." + return +} + +proc ToPressButton {parent btn} { + global isNative + if {!$isNative} { + after 200 "SendButtonPress $parent $btn mouse" + } +} + +proc ToChooseColorByKey {parent r g b} { + global isNative + if {!$isNative} { + after 200 ChooseColorByKey $parent $r $g $b + } +} + +proc PressButton {btn} { + event generate $btn <Enter> + event generate $btn <1> -x 5 -y 5 + event generate $btn <ButtonRelease-1> -x 5 -y 5 +} + +proc ChooseColorByKey {parent r g b} { + set w .__tk__color + upvar #0 $w data + + update + $data(red,entry) delete 0 end + $data(green,entry) delete 0 end + $data(blue,entry) delete 0 end + + $data(red,entry) insert 0 $r + $data(green,entry) insert 0 $g + $data(blue,entry) insert 0 $b + + # Manually force the refresh of the color values instead + # of counting on the timing of the event stream to change + # the values for us. + tkColorDialog_HandleRGBEntry $w + + SendButtonPress $parent ok mouse +} + +proc SendButtonPress {parent btn type} { + set w .__tk__color + upvar #0 $w data + + set button $data($btn\Btn) + if ![winfo ismapped $button] { + update + } + + if {$type == "mouse"} { + PressButton $button + } else { + event generate $w <Enter> + focus $w + event generate $button <Enter> + event generate $w <KeyPress> -keysym Return + } +} + +set parent . + +set verylongstring longstring: +set verylongstring $verylongstring$verylongstring +set verylongstring $verylongstring$verylongstring +set verylongstring $verylongstring$verylongstring +set verylongstring $verylongstring$verylongstring +#set verylongstring $verylongstring$verylongstring +# Interesting thing...when this is too long, the +# delay caused in processing it kills the automated testing, +# and makes a lot of the test cases fail. +#set verylongstring $verylongstring$verylongstring +#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. +set numcolors 32 +set nomorecolors 0 +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]"} { + set nomorecolors 1 + } + } + .c delete $i + incr i +} + +destroy .c + +if {!$nomorecolors} { + set color #404040 + test clrpick-2.1 {tk_chooseColor command} { + ToPressButton $parent ok + tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color -parent $parent + } "$color" + + set color #808040 + test clrpick-2.2 {tk_chooseColor command} { + if {$tcl_platform(platform) == "macintosh"} { + set colors "32768 32768 16384" + } else { + 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} { + ToPressButton $parent ok + tk_chooseColor -parent $parent -title "Press OK" + } "$color" +} else { + puts "Skipped tests clrpick2.1, clrpick2.2 and clrpick2.3 because" + puts "you ran out of colors in your color palette, and this would" + puts "have caused the tests to generate errors." +} + +test clrpick-2.4 {tk_chooseColor command} { + ToPressButton $parent cancel + tk_chooseColor -parent $parent -title "Press Cancel" +} "" + +set color #000000 +test clrpick-3.1 {tk_chooseColor: background events} { + after 1 {set x 53} + ToPressButton $parent ok + tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color +} "#000000" +test clrpick-3.2 {tk_chooseColor: background events} { + after 1 {set x 53} + ToPressButton $parent cancel + tk_chooseColor -parent $parent -title "Press Cancel" +} "" diff --git a/tests/cmap.tcl b/tests/cmap.tcl new file mode 100644 index 0000000..13c350d --- /dev/null +++ b/tests/cmap.tcl @@ -0,0 +1,61 @@ +# This file creates a visual test for colormaps and the WM_COLORMAP_WINDOWS +# property. It is part of the Tk visual test suite, which is invoked +# via the "visual" script. +# +# SCCS: @(#) cmap.tcl 1.2 96/02/16 10:55:47 + +catch {destroy .t} +toplevel .t -colormap new +wm title .t "Visual Test for Colormaps" +wm iconname .t "Colormaps" +wm geom .t +0+0 + +# The following procedure creates a whole bunch of frames within a +# window, in order to eat up all the colors in a colormap. + +proc colors {w redInc greenInc blueInc} { + set red 0 + set green 0 + set blue 0 + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 8} {incr x} { + frame $w.f$x,$y -width 40 -height 40 -bd 2 -relief raised \ + -bg [format #%02x%02x%02x $red $green $blue] + place $w.f$x,$y -x [expr 40*$x] -y [expr 40*$y] + incr red $redInc + incr green $greenInc + incr blue $blueInc + } + } +} + +message .t.m -width 6i -text {This window displays two nested frames, each with a whole bunch of subwindows that eat up a lot of colors. The toplevel window has its own colormap, which is inherited by the outer frame. The inner frame has its own colormap. As you move the mouse around, the colors in the frames should change back and forth.} +pack .t.m -side top -fill x + +button .t.quit -text Quit -command {destroy .t} +pack .t.quit -side bottom -pady 3 -ipadx 4 -ipady 2 + +frame .t.f -width 700 -height 450 -relief raised -bd 2 +pack .t.f -side top -padx 1c -pady 1c +colors .t.f 4 0 0 +frame .t.f.f -width 350 -height 350 -colormap new -bd 2 -relief raised +place .t.f.f -relx 1.0 -rely 0 -anchor ne +colors .t.f.f 0 4 0 +bind .t.f.f <Enter> {wm colormapwindows .t {.t.f.f .t}} +bind .t.f.f <Leave> {wm colormapwindows .t {.t .t.f.f}} + +catch {destroy .t2} +toplevel .t2 +wm title .t2 "Visual Test for Colormaps" +wm iconname .t2 "Colormaps" +wm geom .t2 +0-0 + +message .t2.m -width 6i -text {This window just eats up most of the colors in the default colormap.} +pack .t2.m -side top -fill x + +button .t2.quit -text Quit -command {destroy .t2} +pack .t2.quit -side bottom -pady 3 -ipadx 4 -ipady 2 + +frame .t2.f -height 320 -width 320 +pack .t2.f -side bottom +colors .t2.f 0 0 4 diff --git a/tests/cmds.test b/tests/cmds.test new file mode 100644 index 0000000..71b14f4 --- /dev/null +++ b/tests/cmds.test @@ -0,0 +1,43 @@ +# This file is a Tcl script to test the procedures in the file +# tkCmds.c. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) cmds.test 1.1 96/03/14 13:25:24 + +if {[string compare test [info procs test]] == 1} { + source defs +} + +eval destroy [winfo child .] +wm geometry . {} +update + +test cmds-1.1 {tkwait visibility, argument errors} { + list [catch {tkwait visibility} msg] $msg +} {1 {wrong # args: should be "tkwait variable|visibility|window name"}} +test cmds-1.2 {tkwait visibility, argument errors} { + list [catch {tkwait visibility foo bar} msg] $msg +} {1 {wrong # args: should be "tkwait variable|visibility|window name"}} +test cmds-1.3 {tkwait visibility, argument errors} { + list [catch {tkwait visibility bad_window} msg] $msg +} {1 {bad window path name "bad_window"}} +test cmds-1.4 {tkwait visibility, waiting for window to be mapped} { + button .b -text "Test" + set x init + after 100 {set x delay; place .b -x 0 -y 0} + tkwait visibility .b + destroy .b + set x +} {delay} +test cmds-1.5 {tkwait visibility, window gets deleted} { + frame .f + button .f.b -text "Test" + pack .f.b + set x init + after 100 {set x deleted; destroy .f} + list [catch {tkwait visibility .f.b} msg] $msg $x +} {1 {window ".f.b" was deleted before its visibility changed} deleted} diff --git a/tests/color.test b/tests/color.test new file mode 100644 index 0000000..030efa0 --- /dev/null +++ b/tests/color.test @@ -0,0 +1,167 @@ +# This file is a Tcl script to test out the procedures in the file +# tkColor.c. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) color.test 1.5 96/02/16 10:56:05 + +if {[info procs test] != "test"} { + source defs +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +# cname -- +# Returns a proper name for a color, given its intensities. +# +# Arguments: +# r, g, b - Intensities on a 0-255 scale. + +proc cname {r g b} { + format #%02x%02x%02x $r $g $b +} +proc cname4 {r g b} { + format #%04x%04x%04x $r $g $b +} + +# mkColors -- +# Creates a canvas and fills it with a 2-D array of squares, each of a +# different color. +# +# Arguments: +# c - Name of canvas window to create. +# width - Number of squares in each row. +# height - Number of squares in each column. +# r, g, b - Initial value for red, green, and blue intensities. +# rx, gx, bx - Change in intensities between adjacent elements in row. +# ry, gy, by - Change in intensities between adjacent elements in column. + +proc mkColors {c width height r g b rx gx bx ry gy by} { + catch {destroy $c} + canvas $c -width 400 -height 200 -bd 0 + for {set y 0} {$y < $height} {incr y} { + for {set x 0} {$x < $width} {incr x} { + set color [format #%02x%02x%02x [expr $r + $y*$ry + $x*$rx] \ + [expr $g + $y*$gy + $x*$gx] [expr $b + $y*$by + $x*$bx]] + $c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } + } +} + +# closest - +# Given intensities between 0 and 255, return the closest intensities +# that the server can provide. +# +# Arguments: +# w - Window in which to lookup color +# r, g, b - Desired intensities, between 0 and 255. + +proc closest {w r g b} { + set vals [winfo rgb $w [cname $r $g $b]] + list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \ + [expr [lindex $vals 2]/256] +} + +# c255 - +# Given a list of red, green, and blue intensities, scale them +# down to a 0-255 range. +# +# Arguments: +# vals - List of intensities. + +proc c255 {vals} { + list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \ + [expr [lindex $vals 2]/256] +} + +# colorsFree -- +# +# Returns 1 if there appear to be free colormap entries in a window, +# 0 otherwise. +# +# Arguments: +# w - Name of window in which to check. +# red, green, blue - Intensities to use in a trial color allocation +# to see if there are colormap entries free. + +proc colorsFree {w {red 31} {green 245} {blue 192}} { + set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] + expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ + && ([lindex $vals 2]/256 == $blue) +} + +# Create a top-level with its own colormap (so we can test under +# controlled conditions), then check to make sure that the visual +# is color-mapped with 256 colors. If not, just skip this whole +# test file. + +if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { + return +} +wm geom .t +0+0 +if {[winfo depth .t] != 8} { + destroy .t + return +} +mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40 +pack .t.c +update +if ![colorsFree .t.c 101 233 17] { + destroy .t + return +} +mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 +pack .t.c2 +if [colorsFree .t.c] { + destroy .t + return +} +destroy .t.c .t.c2 + +test color-1.1 {Tk_GetColor procedure} { + c255 [winfo rgb .t red] +} {255 0 0} +test color-1.2 {Tk_GetColor procedure} { + list [catch {winfo rgb .t noname} msg] $msg +} {1 {unknown color name "noname"}} + +test color-1.3 {Tk_GetColor procedure} { + c255 [winfo rgb .t #123456] +} {18 52 86} +test color-1.4 {Tk_GetColor procedure} { + list [catch {winfo rgb .t #xyz} msg] $msg +} {1 {invalid color name "#xyz"}} + +test color-2.1 {Tk_FreeColor procedure, reference counting} { + eval destroy [winfo child .t] + mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 + pack .t.c + mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 + pack .t.c2 + update + set last [.t.c2 create rectangle 50 50 70 60 -outline {} \ + -fill [cname 0 240 240]] + .t.c delete 1 + set result [colorsFree .t] + .t.c2 delete $last + lappend result [colorsFree .t] +} {0 1} +test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} { + eval destroy [winfo child .t] + mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 + pack .t.c + mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 + mkColors .t.c2 20 1 250 250 0 -10 -10 0 0 0 0 + pack .t.c2 + update + closest .t 241 241 1 +} {240 240 0} + +destroy .t diff --git a/tests/defs b/tests/defs new file mode 100644 index 0000000..df518da --- /dev/null +++ b/tests/defs @@ -0,0 +1,367 @@ +# This file contains support code for the Tcl test suite. It is +# normally sourced by the individual files in the test suite before +# they run their tests. This improved approach to testing was designed +# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. +# +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) defs 1.39 97/08/06 15:32:02 + +if ![info exists VERBOSE] { + set VERBOSE 0 +} +if ![info exists TESTS] { + set TESTS {} +} + +tk appname tktest +wm title . tktest + +# Check configuration information that will determine which tests +# to run. To do this, create an array testConfig. Each element +# has a 0 or 1 value, and the following elements are defined: +# unixOnly - 1 means this is a UNIX platform, so it's OK +# to run tests that only work under UNIX. +# macOnly - 1 means this is a Mac platform, so it's OK +# to run tests that only work on Macs. +# pcOnly - 1 means this is a PC platform, so it's OK to +# run tests that only work on PCs. +# unixOrPc - 1 means this is a UNIX or PC platform. +# macOrPc - 1 means this is a Mac or PC platform. +# macOrUnix - 1 means this is a Mac or UNIX platform. +# nonPortable - 1 means this the tests are being running in +# the master Tcl/Tk development environment; +# Some tests are inherently non-portable because +# they depend on things like word length, file system +# configuration, window manager, etc. These tests +# are only run in the main Tcl development directory +# where the configuration is well known. The presence +# of the file "doAllTests" in this directory indicates +# that it is safe to run non-portable tests. +# fonts - 1 means that this platform uses fonts with +# well-know geometries, so it is safe to run +# tests that depend on particular font sizes. + +catch {unset testConfig} + +set testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}] +set testConfig(macOnly) [expr {$tcl_platform(platform) == "macintosh"}] +set testConfig(pcOnly) [expr {$tcl_platform(platform) == "windows"}] + +set testConfig(unix) $testConfig(unixOnly) +set testConfig(mac) $testConfig(macOnly) +set testConfig(pc) $testConfig(pcOnly) + +set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)] +set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)] +set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)] + +set testConfig(nonPortable) [expr [file exists doAllTests] || [file exists DOALLT~1]] + +set testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}] +set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] +set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}] + +# The following config switches are used to mark tests that should work, +# but have been temporarily disabled on certain platforms because they don't. + +set testConfig(tempNotPc) [expr !$testConfig(pc)] +set testConfig(tempNotMac) [expr !$testConfig(mac)] +set testConfig(tempNotUnix) [expr !$testConfig(unix)] + +# The following config switches are used to mark tests that crash on +# certain platforms, so that they can be reactivated again when the +# underlying problem is fixed. + +set testConfig(pcCrash) [expr !$testConfig(pc)] +set testConfig(win32sCrash) [expr !$testConfig(win32s)] +set testConfig(macCrash) [expr !$testConfig(mac)] +set testConfig(unixCrash) [expr !$testConfig(unix)] + +set testConfig(fonts) 1 +catch {destroy .e} +entry .e -width 0 -font {Helvetica -12} -bd 1 +.e insert end "a.bcd" +if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { + set testConfig(fonts) 0 +} +destroy .e .t +text .t -width 80 -height 20 -font {Times -14} -bd 1 +pack .t +.t insert end "This is\na dot." +update +set x [list [.t bbox 1.3] [.t bbox 2.5]] +destroy .t +if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} { + set testConfig(fonts) 0 +} + +if {$testConfig(nonPortable) == 0} { + puts "(will skip non-portable tests)" +} +if {$testConfig(fonts) == 0} { + puts "(will skip font-sensitive tests: this system has unexpected font geometries)" +} + +trace variable testConfig r safeFetch + +proc safeFetch {n1 n2 op} { + global testConfig + + if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} { + set testConfig($n2) 0 + } +} + +# If there is no "memory" command (because memory debugging isn't +# enabled), generate a dummy command that does nothing. + +if {[info commands memory] == ""} { + proc memory args {} +} + +proc print_verbose {name description script code answer} { + puts stdout "\n" + puts stdout "==== $name $description" + puts stdout "==== Contents of test case:" + puts stdout "$script" + if {$code != 0} { + if {$code == 1} { + puts stdout "==== Test generated error:" + puts stdout $answer + } elseif {$code == 2} { + puts stdout "==== Test generated return exception; result was:" + puts stdout $answer + } elseif {$code == 3} { + puts stdout "==== Test generated break exception" + } elseif {$code == 4} { + puts stdout "==== Test generated continue exception" + } else { + puts stdout "==== Test generated exception $code; message was:" + puts stdout $answer + } + } else { + puts stdout "==== Result was:" + puts stdout "$answer" + } +} + +# test -- +# This procedure runs a test and prints an error message if the +# test fails. If VERBOSE has been set, it also prints a message +# even if the test succeeds. The test will be skipped if it +# doesn't match the TESTS variable, or if one of the elements +# of "constraints" turns out not to be true. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "testConfig". If any of these +# elements is zero, the test is skipped. +# This argument may be omitted. +# script - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. +# answer - Expected result from script. + +proc test {name description script answer args} { + global VERBOSE TESTS testConfig + if {[string compare $TESTS ""] != 0} { + set ok 0 + foreach test $TESTS { + if {[string match $test $name]} { + set ok 1 + break + } + } + if {!$ok} { + return + } + } + set i [llength $args] + if {$i == 0} { + # Empty body + } elseif {$i == 1} { + # "constraints" argument exists; shuffle arguments down, then + # make sure that the constraints are satisfied. + + set constraints $script + set script $answer + set answer [lindex $args 0] + set doTest 0 + if {[string match {*[$\[]*} $constraints] != 0} { + # full expression, e.g. {$foo > [info tclversion]} + + catch {set doTest [uplevel #0 expr $constraints]} + } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { + # something like {a || b} should be turned into + # $testConfig(a) || $testConfig(b). + + regsub -all {[.a-zA-Z0-9]+} $constraints {$testConfig(&)} c + catch {set doTest [eval expr $c]} + } else { + # just simple constraints such as {unixOnly fonts}. + + set doTest 1 + foreach constraint $constraints { + if {![info exists testConfig($constraint)] + || !$testConfig($constraint)} { + set doTest 0 + break + } + } + } + if {$doTest == 0} { + if {$VERBOSE} { + puts stdout "++++ $name SKIPPED: $constraints" + } + return + } + } else { + error "wrong # args: must be \"test name description ?constraints? script answer\"" + } + memory tag $name + set code [catch {uplevel $script} result] + if {$code != 0} { + print_verbose $name $description $script $code $result + } elseif {[string compare $result $answer] == 0} { + if {$VERBOSE} then { + if {$VERBOSE > 0} { + print_verbose $name $description $script $code $result + } + if {$VERBOSE != -2} { + puts stdout "++++ $name PASSED" + } + } + } else { + print_verbose $name $description $script $code $result + puts stdout "---- Result should have been:" + puts stdout "$answer" + puts stdout "---- $name FAILED" + } +} + +proc dotests {file args} { + global TESTS + set savedTests $TESTS + set TESTS $args + source $file + set TESTS $savedTests +} + +# If the main window isn't already mapped (e.g. because the tests are +# being run automatically) , specify a precise size for it so that the +# user won't have to position it manually. + +if {![winfo ismapped .]} { + wm geometry . +0+0 + update +} + +# The following code can be used to perform tests involving a second +# process running in the background. + +# Locate tktest executable + +set tktest [info nameofexecutable] +if {$tktest == "{}"} { + set tktest {} + puts "Unable to find tktest executable, skipping multiple process tests." +} + +# Create background process + +proc setupbg {{args ""}} { + global tktest fd bgData + if {$tktest == ""} { + error "you're not running tktest so setupbg should not have been called" + } + if {[info exists fd] && ($fd != "")} { + cleanupbg + } + set fd [open "|[list $tktest -geometry +0+0 -name tktest] $args" r+] + puts $fd "puts foo; flush stdout" + flush $fd + if {[gets $fd data] < 0} { + error "unexpected EOF from \"$tktest\"" + } + if [string compare $data foo] { + error "unexpected output from background process \"$data\"" + } + fileevent $fd readable bgReady +} + +# Send a command to the background process, catching errors and +# flushing I/O channels +proc dobg {command} { + global fd bgData bgDone + puts $fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout" + flush $fd + set bgDone 0 + set bgData {} + tkwait variable bgDone + set bgData +} + +# Data arrived from background process. Check for special marker +# indicating end of data for this command, and make data available +# to dobg procedure. +proc bgReady {} { + global fd bgData bgDone + set x [gets $fd] + if [eof $fd] { + fileevent $fd readable {} + set bgDone 1 + } elseif {$x == "**DONE**"} { + set bgDone 1 + } else { + append bgData $x + } +} + +# Exit the background process, and close the pipes +proc cleanupbg {} { + global fd + catch { + puts $fd "exit" + close $fd + } + set fd "" +} + +# Clean up focus after using generate event, which +# can leave the window manager with the wrong impression +# about who thinks they have the focus. (BW) + +proc fixfocus {} { + catch {destroy .focus} + toplevel .focus + wm geometry .focus +0+0 + entry .focus.e + .focus.e insert 0 "fixfocus" + pack .focus.e + update + focus -force .focus.e + destroy .focus +} + +proc makeFile {contents name} { + set fd [open $name w] + fconfigure $fd -translation lf + if {[string index $contents [expr [string length $contents] - 1]] == "\n"} { + puts -nonewline $fd $contents + } else { + puts $fd $contents + } + close $fd +} + +proc removeFile {name} { + file delete -- $name +} diff --git a/tests/entry.test b/tests/entry.test new file mode 100644 index 0000000..950d278 --- /dev/null +++ b/tests/entry.test @@ -0,0 +1,1269 @@ +# This file is a Tcl script to test entry widgets in Tk. It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) entry.test 1.49 97/11/07 09:34:31 + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\"" + puts "image, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +proc scroll args { + global scrollInfo + set scrollInfo $args +} + +# Create additional widget that's used to hold the selection at times. + +entry .sel +.sel insert end "This is some sample text" + +# Font names + +set big -adobe-helvetica-medium-r-normal--24-240-75-75-p-*-iso8859-1 +set fixed -adobe-courier-medium-r-normal--12-120-75-75-m-*-iso8859-1 + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Entry.borderWidth 2 +option add *Entry.highlightThickness 2 +option add *Entry.font {Helvetica -12} + +entry .e -bd 2 -relief sunken +pack .e +update +set i 1 +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"}} + {-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}} + {-fg #110022 #110022 bogus {unknown color name "bogus"}} + {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {} + {font "" doesn't exist}} + {-foreground #110022 #110022 bogus {unknown color name "bogus"}} + {-highlightbackground #123456 #123456 ugly {unknown color name "ugly"}} + {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}} + {-highlightthickness 6 6 bogus {bad screen distance "bogus"}} + {-highlightthickness -2 0 {} {}} + {-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"}} + {-justify right right bogus {bad justification "bogus": must be left, right, or center}} + {-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"}} + {-show * * {} {}} + {-state normal normal bogus {bad state value "bogus": must be normal or disabled}} + {-takefocus "any string" "any string" {} {}} + {-textvariable i i {} {}} + {-width 402 402 3p {expected integer but got "3p"}} + {-xscrollcommand {Some command} {Some command} {} {}} +} { + set name [lindex $test 0] + test entry-1.1 {configuration options} { + .e configure $name [lindex $test 1] + list [lindex [.e configure $name] 4] [.e cget $name] + } [list [lindex $test 2] [lindex $test 2]] + incr i + if {[lindex $test 3] != ""} { + test entry-1.2 {configuration options} { + list [catch {.e configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .e configure $name [lindex [.e configure $name] 3] + incr i +} + +test entry-2.1 {Tk_EntryCmd procedure} { + list [catch {entry} msg] $msg +} {1 {wrong # args: should be "entry pathName ?options?"}} +test entry-2.2 {Tk_EntryCmd procedure} { + list [catch {entry gorp} msg] $msg +} {1 {bad window path name "gorp"}} +test entry-2.3 {Tk_EntryCmd procedure} { + catch {destroy .e} + entry .e + list [winfo exists .e] [winfo class .e] [info commands .e] +} {1 Entry .e} +test entry-2.4 {Tk_EntryCmd procedure} { + catch {destroy .e} + list [catch {entry .e -gorp foo} msg] $msg [winfo exists .e] \ + [info commands .e] +} {1 {unknown option "-gorp"} 0 {}} +test entry-2.5 {Tk_EntryCmd procedure} { + catch {destroy .e} + entry .e +} {.e} + +catch {destroy .e} +entry .e -font $fixed +pack .e +update + +set cx [font measure $fixed a] +set cy [font metrics $fixed -linespace] + +test entry-3.1 {EntryWidgetCmd procedure} { + list [catch {.e} msg] $msg +} {1 {wrong # args: should be ".e option ?arg arg ...?"}} +test entry-3.2 {EntryWidgetCmd procedure, "bbox" widget command} { + list [catch {.e bbox} msg] $msg +} {1 {wrong # args: should be ".e bbox index"}} +test entry-3.3 {EntryWidgetCmd procedure, "bbox" widget command} { + list [catch {.e bbox a b} msg] $msg +} {1 {wrong # args: should be ".e bbox index"}} +test entry-3.4 {EntryWidgetCmd procedure, "bbox" widget command} { + list [catch {.e bbox bogus} msg] $msg +} {1 {bad entry index "bogus"}} +test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} { + .e delete 0 end + .e bbox 0 +} [list 5 5 0 $cy] +test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} {fonts} { + .e delete 0 end + .e insert 0 "abcdefghijklmnop" + list [.e bbox 0] [.e bbox 1] [.e bbox end] +} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+15*$cx] 5 $cx $cy"] +test entry-3.7 {EntryWidgetCmd procedure, "cget" widget command} { + list [catch {.e cget} msg] $msg +} {1 {wrong # args: should be ".e cget option"}} +test entry-3.8 {EntryWidgetCmd procedure, "cget" widget command} { + list [catch {.e cget a b} msg] $msg +} {1 {wrong # args: should be ".e cget option"}} +test entry-3.9 {EntryWidgetCmd procedure, "cget" widget command} { + list [catch {.e cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test entry-3.10 {EntryWidgetCmd procedure, "cget" widget command} { + .e configure -bd 4 + .e cget -bd +} {4} +test entry-3.11 {EntryWidgetCmd procedure, "configure" widget command} { + llength [.e configure] +} {28} +test entry-3.12 {EntryWidgetCmd procedure, "configure" widget command} { + list [catch {.e configure -foo} msg] $msg +} {1 {unknown option "-foo"}} +test entry-3.13 {EntryWidgetCmd procedure, "configure" widget command} { + .e configure -bd 4 + .e configure -bg #ffffff + lindex [.e configure -bd] 4 +} {4} +test entry-3.14 {EntryWidgetCmd procedure, "delete" widget command} { + list [catch {.e delete} msg] $msg +} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} +test entry-3.15 {EntryWidgetCmd procedure, "delete" widget command} { + list [catch {.e delete a b c} msg] $msg +} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} +test entry-3.16 {EntryWidgetCmd procedure, "delete" widget command} { + list [catch {.e delete foo} msg] $msg +} {1 {bad entry index "foo"}} +test entry-3.17 {EntryWidgetCmd procedure, "delete" widget command} { + list [catch {.e delete 0 bar} msg] $msg +} {1 {bad entry index "bar"}} +test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} { + .e delete 0 end + .e insert end "01234567890" + .e delete 2 4 + .e get +} {014567890} +test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} { + .e delete 0 end + .e insert end "01234567890" + .e delete 6 + .e get +} {0123457890} +test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} { + .e delete 0 end + .e insert end "01234567890" + .e delete 6 5 + .e get +} {01234567890} +test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} { + .e delete 0 end + .e insert end "01234567890" + .e configure -state disabled + .e delete 2 8 + .e configure -state normal + .e get +} {01234567890} +test entry-3.22 {EntryWidgetCmd procedure, "get" widget command} { + list [catch {.e get foo} msg] $msg +} {1 {wrong # args: should be ".e get"}} +test entry-3.23 {EntryWidgetCmd procedure, "icursor" widget command} { + list [catch {.e icursor} msg] $msg +} {1 {wrong # args: should be ".e icursor pos"}} +test entry-3.24 {EntryWidgetCmd procedure, "icursor" widget command} { + list [catch {.e icursor foo} msg] $msg +} {1 {bad entry index "foo"}} +test entry-3.25 {EntryWidgetCmd procedure, "icursor" widget command} { + .e delete 0 end + .e insert end "01234567890" + .e icursor 4 + .e index insert +} {4} +test entry-3.26 {EntryWidgetCmd procedure, "index" widget command} { + list [catch {.e in} msg] $msg +} {1 {bad option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, or xview}} +test entry-3.27 {EntryWidgetCmd procedure, "index" widget command} { + list [catch {.e index} msg] $msg +} {1 {wrong # args: should be ".e index string"}} +test entry-3.28 {EntryWidgetCmd procedure, "index" widget command} { + list [catch {.e index foo} msg] $msg +} {1 {bad entry index "foo"}} +test entry-3.29 {EntryWidgetCmd procedure, "index" widget command} { + list [catch {.e index 0} msg] $msg +} {0 0} +test entry-3.30 {EntryWidgetCmd procedure, "insert" widget command} { + list [catch {.e insert a} msg] $msg +} {1 {wrong # args: should be ".e insert index text"}} +test entry-3.31 {EntryWidgetCmd procedure, "insert" widget command} { + list [catch {.e insert a b c} msg] $msg +} {1 {wrong # args: should be ".e insert index text"}} +test entry-3.32 {EntryWidgetCmd procedure, "insert" widget command} { + list [catch {.e insert foo Text} msg] $msg +} {1 {bad entry index "foo"}} +test entry-3.33 {EntryWidgetCmd procedure, "insert" widget command} { + .e delete 0 end + .e insert end "01234567890" + .e insert 3 xxx + .e get +} {012xxx34567890} +test entry-3.34 {EntryWidgetCmd procedure, "insert" widget command} { + .e delete 0 end + .e insert end "01234567890" + .e configure -state disabled + .e insert 3 xxx + .e configure -state normal + .e get +} {01234567890} +test entry-3.35 {EntryWidgetCmd procedure, "insert" widget command} { + list [catch {.e insert a b c} msg] $msg +} {1 {wrong # args: should be ".e insert index text"}} +test entry-3.36 {EntryWidgetCmd procedure, "scan" widget command} { + list [catch {.e scan a} msg] $msg +} {1 {wrong # args: should be ".e scan mark|dragto x"}} +test entry-3.37 {EntryWidgetCmd procedure, "scan" widget command} { + list [catch {.e scan a b c} msg] $msg +} {1 {wrong # args: should be ".e scan mark|dragto x"}} +test entry-3.38 {EntryWidgetCmd procedure, "scan" widget command} { + list [catch {.e scan foobar 20} msg] $msg +} {1 {bad scan option "foobar": must be mark or dragto}} +test entry-3.39 {EntryWidgetCmd procedure, "scan" widget command} { + list [catch {.e scan mark 20.1} msg] $msg +} {1 {expected integer but got "20.1"}} +# This test is non-portable because character sizes vary. + +test entry-3.40 {EntryWidgetCmd procedure, "scan" widget command} {fonts} { + .e delete 0 end + update + .e insert end "This is quite a long string, in fact a " + .e insert end "very very long string" + .e scan mark 30 + .e scan dragto 28 + .e index @0 +} {2} +test entry-3.41 {EntryWidgetCmd procedure, "select" widget command} { + list [catch {.e select} msg] $msg +} {1 {wrong # args: should be ".e select option ?index?"}} +test entry-3.42 {EntryWidgetCmd procedure, "select" widget command} { + list [catch {.e select foo} msg] $msg +} {1 {bad selection option "foo": must be adjust, clear, from, present, range, or to}} +test entry-3.43 {EntryWidgetCmd procedure, "select clear" widget command} { + list [catch {.e select clear gorp} msg] $msg +} {1 {wrong # args: should be ".e selection clear"}} +test entry-3.44 {EntryWidgetCmd procedure, "select clear" widget command} { + .e delete 0 end + .e insert end "0123456789" + .e select from 1 + .e select to 4 + update + .e select clear + list [catch {selection get} msg] $msg [selection own] +} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} .e} +test entry-3.45 {EntryWidgetCmd procedure, "selection present" widget command} { + list [catch {.e selection present foo} msg] $msg +} {1 {wrong # args: should be ".e selection present"}} +test entry-3.46 {EntryWidgetCmd procedure, "selection present" widget command} { + .e delete 0 end + .e insert end 0123456789 + .e select from 3 + .e select to 6 + .e selection present +} {1} +test entry-3.47 {EntryWidgetCmd procedure, "selection present" widget command} { + .e delete 0 end + .e insert end 0123456789 + .e select from 3 + .e select to 6 + .e configure -exportselection false + .e selection present +} {1} +.e configure -exportselection true +test entry-3.48 {EntryWidgetCmd procedure, "selection present" widget command} { + .e delete 0 end + .e insert end 0123456789 + .e select from 3 + .e select to 6 + .e delete 0 end + .e selection present +} {0} +test entry-3.49 {EntryWidgetCmd procedure, "selection adjust" widget command} { + list [catch {.e select adjust x} msg] $msg +} {1 {bad entry index "x"}} +test entry-3.50 {EntryWidgetCmd procedure, "selection adjust" widget command} { + list [catch {.e select adjust 2 3} msg] $msg +} {1 {wrong # args: should be ".e selection adjust index"}} +test entry-3.51 {EntryWidgetCmd procedure, "selection adjust" widget command} { + .e delete 0 end + .e insert end "0123456789" + .e select from 1 + .e select to 5 + update + .e select adjust 4 + selection get +} {123} +test entry-3.52 {EntryWidgetCmd procedure, "selection adjust" widget command} { + .e delete 0 end + .e insert end "0123456789" + .e select from 1 + .e select to 5 + update + .e select adjust 2 + selection get +} {234} +test entry-3.53 {EntryWidgetCmd procedure, "selection from" widget command} { + list [catch {.e select from 2 3} msg] $msg +} {1 {wrong # args: should be ".e selection from index"}} +test entry-3.54 {EntryWidgetCmd procedure, "selection range" widget command} { + list [catch {.e select range 2} msg] $msg +} {1 {wrong # args: should be ".e selection range start end"}} +test entry-3.55 {EntryWidgetCmd procedure, "selection range" widget command} { + list [catch {.e selection range 2 3 4} msg] $msg +} {1 {wrong # args: should be ".e selection range start end"}} +test entry-3.56 {EntryWidgetCmd procedure, "selection range" widget command} { + .e delete 0 end + .e insert end 0123456789 + .e select from 1 + .e select to 5 + .e select range 4 4 + list [catch {.e index sel.first} msg] $msg +} {1 {selection isn't in entry}} +test entry-3.57 {EntryWidgetCmd procedure, "selection range" widget command} { + .e delete 0 end + .e insert end 0123456789 + .e select from 3 + .e select to 7 + .e select range 2 9 + list [.e index sel.first] [.e index sel.last] [.e index anchor] +} {2 9 3} +.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.58 {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.59 {EntryWidgetCmd procedure, "xview" widget command} { + .e xview 5 + .e xview +} {0.0537634 0.268817} +test entry-3.60 {EntryWidgetCmd procedure, "xview" widget command} { + list [catch {.e xview gorp} msg] $msg +} {1 {bad entry index "gorp"}} +test entry-3.61 {EntryWidgetCmd procedure, "xview" widget command} { + .e xview 0 + .e icursor 10 + .e xview insert + .e xview +} {0.107527 0.322581} +test entry-3.62 {EntryWidgetCmd procedure, "xview" widget command} { + list [catch {.e xview moveto foo bar} msg] $msg +} {1 {wrong # args: should be ".e xview moveto fraction"}} +test entry-3.63 {EntryWidgetCmd procedure, "xview" widget command} { + list [catch {.e xview moveto foo} msg] $msg +} {1 {expected floating-point number but got "foo"}} +test entry-3.64 {EntryWidgetCmd procedure, "xview" widget command} { + .e xview moveto 0.5 + .e xview +} {0.505376 0.72043} +test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} { + list [catch {.e xview scroll 24} msg] $msg +} {1 {wrong # args: should be ".e xview scroll number units|pages"}} +test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} { + list [catch {.e xview scroll gorp units} msg] $msg +} {1 {expected integer but got "gorp"}} +test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} { + .e xview moveto 0 + .e xview scroll 1 pages + .e xview +} {0.193548 0.408602} +test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} { + .e xview moveto .9 + update + .e xview scroll -2 p + .e xview +} {0.397849 0.612903} +test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} { + .e xview 30 + update + .e xview scroll 2 units + .e index @0 +} {32} +test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} { + .e xview 30 + update + .e xview scroll -1 units + .e index @0 +} {29} +test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} { + list [catch {.e xview scroll 23 foobars} msg] $msg +} {1 {bad argument "foobars": must be units or pages}} +test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} { + list [catch {.e xview eat 23 hamburgers} msg] $msg +} {1 {unknown option "eat": must be moveto or scroll}} +test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} { + .e xview 0 + update + .e xview -4 + .e index @0 +} {0} +test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} { + .e xview 300 + .e index @0 +} {73} +test entry-3.75 {EntryWidgetCmd procedure} { + list [catch {.e gorp} msg] $msg +} {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, or xview}} + +# The test below doesn't actually check anything directly, but if run +# with Purify or some other memory-allocation-checking program it will +# ensure that resources get properly freed. + +test entry-4.1 {DestroyEntry procedure} { + catch {destroy .e} + entry .e -textvariable x -show * + pack .e + .e insert end "Sample text" + update + destroy .e +} {} + +frame .f -width 200 -height 50 -relief raised -bd 2 +pack .f -side right +test entry-5.1 {ConfigureEntry procedure, -textvariable} { + catch {destroy .e} + set x 12345 + entry .e -textvariable x + .e get +} {12345} +test entry-5.2 {ConfigureEntry procedure, -textvariable} { + catch {destroy .e} + set x 12345 + entry .e -textvariable x + set y abcde + .e configure -textvariable y + set x 54321 + .e get +} {abcde} +test entry-5.3 {ConfigureEntry procedure, -textvariable} { + catch {destroy .e} + catch {unset x} + entry .e + .e insert 0 "Some text" + .e configure -textvariable x + set x +} {Some text} +test entry-5.4 {ConfigureEntry procedure, -textvariable} { + proc override args { + global x + set x 12345 + } + catch {destroy .e} + catch {unset x} + trace variable x w override + entry .e + .e insert 0 "Some text" + .e configure -textvariable x + set result [list $x [.e get]] + unset x; rename override {} + set result +} {12345 12345} +test entry-5.5 {ConfigureEntry procedure} { + catch {destroy .e} + entry .e -exportselection false + pack .e + .e insert end "0123456789" + .sel select from 0 + .sel select to 10 + set x {} + lappend x [selection get] + .e select from 1 + .e select to 5 + lappend x [selection get] + .e configure -exportselection 1 + lappend x [selection get] + set x +} {{This is so} {This is so} 1234} +test entry-5.6 {ConfigureEntry procedure} { + catch {destroy .e} + entry .e + pack .e + .e insert end "0123456789" + .e select from 1 + .e select to 5 + .e configure -exportselection 0 + list [catch {selection get} msg] $msg [.e index sel.first] \ + [.e index sel.last] +} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 5} +test entry-5.7 {ConfigureEntry procedure} { + catch {destroy .e} + entry .e -font $fixed -width 4 -xscrollcommand scroll + pack .e + .e insert end "01234567890" + update + .e configure -width 5 + set scrollInfo +} {0 0.363636} +test entry-5.8 {ConfigureEntry procedure} {fonts} { + catch {destroy .e} + entry .e -width 0 + pack .e + .e insert end "0123" + update + .e configure -font $big + update + winfo geom .e +} {62x37+0+0} +test entry-5.9 {ConfigureEntry procedure} {fonts} { + catch {destroy .e} + entry .e -font $fixed -bd 2 -relief raised + pack .e + .e insert end "0123" + update + list [.e index @10] [.e index @11] [.e index @12] [.e index @13] +} {0 0 1 1} +test entry-5.10 {ConfigureEntry procedure} {fonts} { + catch {destroy .e} + entry .e -font $fixed -bd 2 -relief flat + pack .e + .e insert end "0123" + update + list [.e index @10] [.e index @11] [.e index @12] [.e index @13] +} {0 0 1 1} +test entry-5.11 {ConfigureEntry procedure} { + # If "0" in selected font had 0 width, caused divide-by-zero error. + + catch {destroy .e} + pack [entry .e -font {{open look glyph}}] + .e scan dragto 30 + update +} {} + +# No tests for DisplayEntry. + +test entry-6.1 {EntryComputeGeometry procedure} {fonts} { + catch {destroy .e} + entry .e -font $fixed -bd 2 -relief raised -width 20 -highlightthickness 3 + pack .e + .e insert end 012\t45 + update + list [.e index @61] [.e index @62] +} {3 4} +test entry-6.2 {EntryComputeGeometry procedure} {fonts} { + catch {destroy .e} + entry .e -font $fixed -bd 2 -relief raised -width 20 -justify center \ + -highlightthickness 3 + pack .e + .e insert end 012\t45 + update + list [.e index @96] [.e index @97] +} {3 4} +test entry-6.3 {EntryComputeGeometry procedure} {fonts} { + catch {destroy .e} + entry .e -font $fixed -bd 2 -relief raised -width 20 -justify right \ + -highlightthickness 3 + pack .e + .e insert end 012\t45 + update + list [.e index @131] [.e index @132] +} {3 4} +test entry-6.4 {EntryComputeGeometry procedure} { + catch {destroy .e} + entry .e -font $fixed -bd 2 -relief raised -width 5 + pack .e + .e insert end "01234567890" + update + .e xview 6 + .e index @0 +} {6} +test entry-6.5 {EntryComputeGeometry procedure} { + catch {destroy .e} + entry .e -font $fixed -bd 2 -relief raised -width 5 + pack .e + .e insert end "01234567890" + update + .e xview 7 + .e index @0 +} {6} +test entry-6.6 {EntryComputeGeometry procedure} {fonts} { + catch {destroy .e} + entry .e -font $fixed -bd 2 -relief raised -width 10 + pack .e + .e insert end "01234\t67890" + update + .e xview 3 + list [.e index @39] [.e index @40] +} {5 6} +test entry-6.7 {EntryComputeGeometry procedure} {fonts} { + catch {destroy .e} + entry .e -font $big -bd 3 -relief raised -width 5 + pack .e + .e insert end "01234567" + update + list [winfo reqwidth .e] [winfo reqheight .e] +} {77 39} +test entry-6.8 {EntryComputeGeometry procedure} {fonts} { + catch {destroy .e} + entry .e -font $big -bd 3 -relief raised -width 0 + pack .e + .e insert end "01234567" + update + list [winfo reqwidth .e] [winfo reqheight .e] +} {116 39} +test entry-6.9 {EntryComputeGeometry procedure} {fonts} { + catch {destroy .e} + entry .e -font $big -bd 3 -relief raised -width 0 -highlightthickness 2 + pack .e + update + list [winfo reqwidth .e] [winfo reqheight .e] +} {25 39} +test entry-6.10 {EntryComputeGeometry procedure} {fonts} { + catch {destroy .e} + entry .e -bd 1 -relief raised -width 0 -show . + .e insert 0 12345 + pack .e + update + set x [winfo reqwidth .e] + .e configure -show X + lappend x [winfo reqwidth .e] + .e configure -show "" + lappend x [winfo reqwidth .e] +} {23 53 43} + +catch {destroy .e} +entry .e -width 10 -font $fixed -textvariable contents -xscrollcommand scroll +pack .e +focus .e +test entry-7.1 {InsertChars procedure} { + .e delete 0 end + .e insert 0 abcde + .e insert 2 XXX + update + list [.e get] $contents $scrollInfo +} {abXXXcde abXXXcde {0 1}} +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}} +test entry-7.3 {InsertChars procedure} { + .e delete 0 end + .e insert 0 0123456789 + .e select from 2 + .e select to 6 + .e insert 2 XXX + set x "[.e index sel.first] [.e index sel.last]" + .e select to 8 + lappend x [.e index sel.first] [.e index sel.last] +} {5 9 5 8} +test entry-7.4 {InsertChars procedure} { + .e delete 0 end + .e insert 0 0123456789 + .e select from 2 + .e select to 6 + .e insert 3 XXX + set x "[.e index sel.first] [.e index sel.last]" + .e select to 8 + lappend x [.e index sel.first] [.e index sel.last] +} {2 9 2 8} +test entry-7.5 {InsertChars procedure} { + .e delete 0 end + .e insert 0 0123456789 + .e select from 2 + .e select to 6 + .e insert 5 XXX + set x "[.e index sel.first] [.e index sel.last]" + .e select to 8 + lappend x [.e index sel.first] [.e index sel.last] +} {2 9 2 8} +test entry-7.6 {InsertChars procedure} { + .e delete 0 end + .e insert 0 0123456789 + .e select from 2 + .e select to 6 + .e insert 6 XXX + set x "[.e index sel.first] [.e index sel.last]" + .e select to 5 + lappend x [.e index sel.first] [.e index sel.last] +} {2 6 2 5} +test entry-7.7 {InsertChars procedure} { + .e delete 0 end + .e insert 0 0123456789 + .e icursor 4 + .e insert 4 XXX + .e index insert +} {7} +test entry-7.8 {InsertChars procedure} { + .e delete 0 end + .e insert 0 0123456789 + .e icursor 4 + .e insert 5 XXX + .e index insert +} {4} +test entry-7.9 {InsertChars procedure} { + .e delete 0 end + .e insert 0 "This is a very long string" + update + .e xview 4 + .e insert 3 XXX + .e index @0 +} {7} +test entry-7.10 {InsertChars procedure} { + .e delete 0 end + .e insert 0 "This is a very long string" + update + .e xview 4 + .e insert 4 XXX + .e index @0 +} {4} +.e configure -width 0 +test entry-7.11 {InsertChars procedure} {fonts} { + .e delete 0 end + .e insert 0 "xyzzy" + update + .e insert 2 00 + winfo reqwidth .e +} {59} + +.e configure -width 10 +test entry-8.1 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 abcde + .e delete 2 4 + update + list [.e get] $contents $scrollInfo +} {abe abe {0 1}} +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}} +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}} +test entry-8.4 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e select from 3 + .e select to 8 + .e delete 1 3 + update + set x "[.e index sel.first] [.e index sel.last]" + .e select to 5 + lappend x [.e index sel.first] [.e index sel.last] +} {1 6 1 5} +test entry-8.5 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e select from 3 + .e select to 8 + .e delete 1 4 + update + set x "[.e index sel.first] [.e index sel.last]" + .e select to 4 + lappend x [.e index sel.first] [.e index sel.last] +} {1 5 1 4} +test entry-8.6 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e select from 3 + .e select to 8 + .e delete 1 7 + update + set x "[.e index sel.first] [.e index sel.last]" + .e select to 5 + lappend x [.e index sel.first] [.e index sel.last] +} {1 2 1 5} +test entry-8.7 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e select from 3 + .e select to 8 + .e delete 1 8 + list [catch {.e index sel.first} msg] $msg +} {1 {selection isn't in entry}} +test entry-8.8 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e select from 3 + .e select to 8 + .e delete 3 7 + update + set x "[.e index sel.first] [.e index sel.last]" + .e select to 8 + lappend x [.e index sel.first] [.e index sel.last] +} {3 4 3 8} +test entry-8.9 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e select from 3 + .e select to 8 + .e delete 3 8 + list [catch {.e index sel.first} msg] $msg +} {1 {selection isn't in entry}} +test entry-8.10 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e select from 8 + .e select to 3 + .e delete 5 8 + update + set x "[.e index sel.first] [.e index sel.last]" + .e select to 8 + lappend x [.e index sel.first] [.e index sel.last] +} {3 5 5 8} +test entry-8.11 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e select from 8 + .e select to 3 + .e delete 8 10 + update + set x "[.e index sel.first] [.e index sel.last]" + .e select to 4 + lappend x [.e index sel.first] [.e index sel.last] +} {3 8 4 8} +test entry-8.12 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e icursor 4 + .e delete 1 4 + .e index insert +} {1} +test entry-8.13 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e icursor 4 + .e delete 1 5 + .e index insert +} {1} +test entry-8.14 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 0123456789abcde + .e icursor 4 + .e delete 4 6 + .e index insert +} {4} +test entry-8.15 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 "This is a very long string" + .e xview 4 + .e delete 1 4 + .e index @0 +} {1} +test entry-8.16 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 "This is a very long string" + .e xview 4 + .e delete 1 5 + .e index @0 +} {1} +test entry-8.17 {DeleteChars procedure} { + .e delete 0 end + .e insert 0 "This is a very long string" + .e xview 4 + .e delete 4 6 + .e index @0 +} {4} +.e configure -width 0 +test entry-8.18 {DeleteChars procedure} {fonts} { + .e delete 0 end + .e insert 0 "xyzzy" + update + .e delete 2 4 + winfo reqwidth .e +} {31} + +test entry-9.1 {EntryValueChanged procedure} { + catch {destroy .e} + proc override args { + global x + set x 12345 + } + catch {unset x} + trace variable x w override + entry .e -textvariable x + .e insert 0 foo + set result [list $x [.e get]] + unset x; rename override {} + set result +} {12345 12345} + +catch {destroy .e} +entry .e +pack .e +.e configure -width 0 +test entry-10.1 {EntrySetValue procedure} {fonts} { + set x abcde + set y ab + .e configure -textvariable x + update + .e configure -textvariable y + update + list [.e get] [winfo reqwidth .e] +} {ab 24} +test entry-10.2 {EntrySetValue procedure, updating selection} { + catch {destroy .e} + entry .e -textvariable x + .e insert 0 "abcdefghjklmnopqrstu" + .e selection range 4 10 + set x "a" + list [catch {.e index sel.first} msg] $msg +} {1 {selection isn't in entry}} +test entry-10.3 {EntrySetValue procedure, updating selection} { + catch {destroy .e} + entry .e -textvariable x + .e insert 0 "abcdefghjklmnopqrstu" + .e selection range 4 10 + set x "abcdefg" + list [.e index sel.first] [.e index sel.last] +} {4 7} +test entry-10.4 {EntrySetValue procedure, updating selection} { + catch {destroy .e} + entry .e -textvariable x + .e insert 0 "abcdefghjklmnopqrstu" + .e selection range 4 10 + set x "abcdefghijklmn" + list [.e index sel.first] [.e index sel.last] +} {4 10} +test entry-10.5 {EntrySetValue procedure, updating display position} { + catch {destroy .e} + entry .e -width 10 -font $fixed -textvariable x + pack .e + .e insert 0 "abcdefghjklmnopqrstuvwxyz" + .e xview 10 + update + set x "abcdefg" + update + .e index @0 +} {0} +test entry-10.6 {EntrySetValue procedure, updating display position} { + catch {destroy .e} + entry .e -width 10 -font $fixed -textvariable x + pack .e + .e insert 0 "abcdefghjklmnopqrstuvwxyz" + .e xview 10 + update + set x "1234567890123456789012" + update + .e index @0 +} {10} +test entry-10.7 {EntrySetValue procedure, updating insertion cursor} { + catch {destroy .e} + entry .e -width 10 -font $fixed -textvariable x + pack .e + .e insert 0 "abcdefghjklmnopqrstuvwxyz" + .e icursor 5 + set x "123" + .e index insert +} {3} +test entry-10.8 {EntrySetValue procedure, updating insertion cursor} { + catch {destroy .e} + entry .e -width 10 -font $fixed -textvariable x + pack .e + .e insert 0 "abcdefghjklmnopqrstuvwxyz" + .e icursor 5 + set x "123456" + .e index insert +} {5} + +test entry-11.1 {EntryEventProc procedure} { + catch {destroy .e} + entry .e + .e insert 0 abcdefg + destroy .e + update +} {} +test entry-11.2 {EntryEventProc procedure} { + eval destroy [winfo children .] + entry .e1 -fg #112233 + rename .e1 .e2 + set x {} + lappend x [winfo children .] + lappend x [.e2 cget -fg] + destroy .e1 + lappend x [info command .e*] [winfo children .] +} {.e1 #112233 {} {}} + +test entry-12.1 {EntryCmdDeletedProc procedure} { + eval destroy [winfo children .] + button .e1 -text "xyz_123" + rename .e1 {} + list [info command .e*] [winfo children .] +} {{} {}} + +catch {destroy .e} +entry .e -font $fixed -width 5 -bd 2 -relief sunken +pack .e +.e insert 0 012345678901234567890 +.e xview 4 +update +test entry-13.1 {GetEntryIndex procedure} { + .e index end +} {21} +test entry-13.2 {GetEntryIndex procedure} { + list [catch {.e index abogus} msg] $msg +} {1 {bad entry index "abogus"}} +test entry-13.3 {GetEntryIndex procedure} { + .e select from 1 + .e select to 6 + .e index anchor +} {1} +test entry-13.4 {GetEntryIndex procedure} { + .e select from 4 + .e select to 1 + .e index anchor +} {4} +test entry-13.5 {GetEntryIndex procedure} { + .e select from 3 + .e select to 15 + .e select adjust 4 + .e index anchor +} {15} +test entry-13.6 {GetEntryIndex procedure} { + list [catch {.e index ebogus} msg] $msg +} {1 {bad entry index "ebogus"}} +test entry-13.7 {GetEntryIndex procedure} { + .e icursor 2 + .e index insert +} {2} +test entry-13.8 {GetEntryIndex procedure} { + list [catch {.e index ibogus} msg] $msg +} {1 {bad entry index "ibogus"}} +test entry-13.9 {GetEntryIndex procedure} { + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +} {1 6} +selection clear .e +test entry-13.10 {GetEntryIndex procedure} {pc} { + .e index sel.first +} {1} +test entry-13.11 {GetEntryIndex procedure} {!pc} { + list [catch {.e index sel.first} msg] $msg +} {1 {selection isn't in entry}} +test entry-13.12 {GetEntryIndex procedure} {pc} { + list [catch {.e index sbogus} msg] $msg +} {1 {bad entry index "sbogus"}} +test entry-13.13 {GetEntryIndex procedure} {!pc} { + list [catch {.e index sbogus} msg] $msg +} {1 {selection isn't in entry}} +test entry-13.14 {GetEntryIndex procedure} { + list [catch {.e index @xyz} msg] $msg +} {1 {bad entry index "@xyz"}} +test entry-13.15 {GetEntryIndex procedure} {fonts} { + .e index @4 +} {4} +test entry-13.16 {GetEntryIndex procedure} {fonts} { + .e index @11 +} {4} +test entry-13.17 {GetEntryIndex procedure} {fonts} { + .e index @12 +} {5} +test entry-13.18 {GetEntryIndex procedure} {fonts} { + .e index @[expr [winfo width .e] - 6] +} {8} +test entry-13.19 {GetEntryIndex procedure} {fonts} { + .e index @[expr [winfo width .e] - 5] +} {9} +test entry-13.20 {GetEntryIndex procedure} { + .e index @1000 +} {9} +test entry-13.21 {GetEntryIndex procedure} { + list [catch {.e index 1xyz} msg] $msg +} {1 {bad entry index "1xyz"}} +test entry-13.22 {GetEntryIndex procedure} { + .e index -10 +} {0} +test entry-13.23 {GetEntryIndex procedure} { + .e index 12 +} {12} +test entry-13.24 {GetEntryIndex procedure} { + .e index 49 +} {21} +test entry-13.25 {GetEntryIndex procedure} {fonts} { + catch {destroy .e} + entry .e -show . + .e insert 0 XXXYZZY + pack .e + update + list [.e index @7] [.e index @8] +} {0 1} + +# XXX Still need to write tests for EntryScanTo and EntrySelectTo. + +set x {} +for {set i 1} {$i <= 500} {incr i} { + append x "This is line $i, out of 500\n" +} +test entry-14.1 {EntryFetchSelection procedure} { + catch {destroy .e} + entry .e + .e insert end "This is a test string" + .e select from 1 + .e select to 18 + selection get +} {his is a test str} +test entry-14.2 {EntryFetchSelection procedure} { + catch {destroy .e} + entry .e -show * + .e insert end "This is a test string" + .e select from 1 + .e select to 18 + selection get +} {*****************} +test entry-14.3 {EntryFetchSelection procedure} { + catch {destroy .e} + entry .e + .e insert end $x + .e select from 0 + .e select to end + string compare [selection get] $x +} 0 + +test entry-15.1 {EntryLostSelection} { + catch {destroy .e} + entry .e + .e insert 0 "Text" + .e select from 0 + .e select to 4 + set result [selection get] + selection clear + .e select from 0 + .e select to 4 + lappend result [selection get] +} {Text Text} + +# No tests for EventuallyRedraw. + +catch {destroy .e} +entry .e -width 10 -xscrollcommand scroll +pack .e +update + +test entry-16.1 {EntryVisibleRange procedure} {fonts} { + .e delete 0 end + .e insert 0 ............................. + .e xview +} {0 0.827586} +test entry-16.2 {EntryVisibleRange procedure} {fonts} { + .e configure -show X + .e delete 0 end + .e insert 0 ............................. + .e xview +} {0 0.275862} +.e configure -show "" +test entry-16.3 {EntryVisibleRange procedure} { + .e delete 0 end + .e xview +} {0 1} + +catch {destroy .e} +entry .e -width 10 -xscrollcommand scroll -font $fixed +pack .e +update +test entry-17.1 {EntryUpdateScrollbar procedure} { + .e delete 0 end + .e insert 0 123 + update + set scrollInfo +} {0 1} +test entry-17.2 {EntryUpdateScrollbar procedure} { + .e delete 0 end + .e insert 0 0123456789abcdef + .e xview 3 + update + set scrollInfo +} {0.1875 0.8125} +test entry-17.3 {EntryUpdateScrollbar procedure} { + .e delete 0 end + .e insert 0 abcdefghijklmnopqrs + .e xview 6 + update + set scrollInfo +} {0.315789 0.842105} +test entry-17.4 {EntryUpdateScrollbar procedure} { + catch {destroy .e} + proc bgerror msg { + global x + set x $msg + } + entry .e -width 5 -xscrollcommand bogus + pack .e + update + rename bgerror {} + list $x $errorInfo +} {{invalid command name "bogus"} {invalid command name "bogus" + while executing +"bogus 0 1" + (horizontal scrolling command executed by entry)}} + +set l [interp hidden] +eval destroy [winfo children .] + +test entry-18.1 {Entry widget vs hiding} { + catch {destroy .e} + entry .e + interp hide {} .e + destroy .e + list [winfo children .] [interp hidden] +} [list {} $l] + +# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc, +# and EntryTextVarProc. + + +option clear diff --git a/tests/event.test b/tests/event.test new file mode 100644 index 0000000..a8ab3de --- /dev/null +++ b/tests/event.test @@ -0,0 +1,41 @@ +# This file is a Tcl script to test the code in tkEvent.c. It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) event.test 1.6 96/09/12 09:25:44 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# XXX This test file is woefully incomplete. Right now it only tests +# a few of the procedures in tkEvent.c. Please add more tests whenever +# possible. + +test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} { + button .b -text Test + pack .b + bindtags .b .b + update + bind .b <Destroy> { + lappend x destroy + event generate .b <1> + } + bind .b <1> { + lappend x button + } + set x {} + destroy .b + set x +} {destroy} diff --git a/tests/filebox.test b/tests/filebox.test new file mode 100644 index 0000000..6bae6c5 --- /dev/null +++ b/tests/filebox.test @@ -0,0 +1,251 @@ +# This file is a Tcl script to test out Tk's "tk_getOpenFile" and +# "tk_getSaveFile" commands. It is organized in the standard fashion +# for Tcl tests. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) filebox.test 1.5 97/10/10 11:03:21 +# + +set tk_strictMotif_old $tk_strictMotif + +#---------------------------------------------------------------------- +# +# Procedures needed by this test file +# +#---------------------------------------------------------------------- + +proc ToPressButton {parent btn} { + global isNative + if {!$isNative} { + after 100 SendButtonPress $parent $btn mouse + } +} + +proc ToEnterFileByKey {parent fileName fileDir} { + global isNative + if {!$isNative} { + after 100 EnterFileByKey $parent [list $fileName] [list $fileDir] + } +} + +proc PressButton {btn} { + event generate $btn <Enter> + event generate $btn <1> -x 5 -y 5 + event generate $btn <ButtonRelease-1> -x 5 -y 5 +} + +proc EnterFileByKey {parent fileName fileDir} { + global tk_strictMotif + set w .__tk_filedialog + upvar #0 [winfo name $w] data + + if {$tk_strictMotif} { + $data(sEnt) delete 0 end + $data(sEnt) insert 0 [file join $fileDir $fileName] + } else { + $data(ent) delete 0 end + $data(ent) insert 0 $fileName + } + + update + SendButtonPress $parent ok mouse +} + +proc SendButtonPress {parent btn type} { + global tk_strictMotif + set w .__tk_filedialog + upvar #0 [winfo name $w] data + + set button $data($btn\Btn) + if ![winfo ismapped $button] { + update + } + + if {$type == "mouse"} { + PressButton $button + } else { + event generate $w <Enter> + focus $w + event generate $button <Enter> + event generate $w <KeyPress> -keysym Return + } +} + + +#---------------------------------------------------------------------- +# +# The test suite proper +# +#---------------------------------------------------------------------- + +if {[string compare test [info procs test]] == 1} { + source defs +} + +if {$tcl_platform(platform) == "unix"} { + set modes "0 1" +} else { + set modes 1 +} + +set unknownOptionsMsg {1 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent or -title}} + +foreach mode $modes { + + # + # Test both the motif version and the "tk" version of the file dialog + # box on Unix. + # + + if {$tcl_platform(platform) == "unix"} { + set tk_strictMotif $mode + } + + # + # Test both the "open" and the "save" dialogs + # + + foreach command "tk_getOpenFile tk_getSaveFile" { + + test filebox-1.1 "$command command" { + list [catch {$command -foo} msg] $msg + } $unknownOptionsMsg + + regsub -all , $msg "" options + regsub \"-foo\" $options "" options + + foreach option $options { + if {[string index $option 0] == "-"} { + test filebox-1.2 "$command command" { + list [catch {$command $option} msg] $msg + } [list 1 "value for \"$option\" missing"] + } + } + + test filebox-1.3 "$command command" { + list [catch {$command -foo bar} msg] $msg + } $unknownOptionsMsg + + test filebox-1.4 "$command command" { + list [catch {$command -initialdir} msg] $msg + } {1 {value for "-initialdir" missing}} + + test filebox-1.5 "$command command" { + list [catch {$command -parent foo.bar} msg] $msg + } {1 {bad window path name "foo.bar"}} + + test filebox-1.6 "$command command" { + list [catch {$command -filetypes {Foo}} msg] $msg + } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}} + + if {[info commands tkMotifFDialog] == "" && [info commands tkFDialog] == ""} { + set isNative 1 + } else { + set isNative 0 + } + + if {$isNative && ![info exists INTERACTIVE]} { + continue + } + + set parent . + + set verylongstring longstring: + set verylongstring $verylongstring$verylongstring + set verylongstring $verylongstring$verylongstring + set verylongstring $verylongstring$verylongstring + set verylongstring $verylongstring$verylongstring +# set verylongstring $verylongstring$verylongstring +# set verylongstring $verylongstring$verylongstring +# set verylongstring $verylongstring$verylongstring +# set verylongstring $verylongstring$verylongstring +# set verylongstring $verylongstring$verylongstring + + set color #404040 + test filebox-2.1 "$command command" { + ToPressButton $parent cancel + $command -title "Press Cancel ($verylongstring)" -parent $parent + } "" + + + if {$command == "tk_getSaveFile"} { + set fileName "12x 455" + set fileDir [pwd] + set pathName [file join [pwd] $fileName] + } else { + set thisFile [info script] + set fileName [file tail $thisFile] + set appPWD [pwd] + cd [file dirname $thisFile] + set fileDir [pwd] + cd $appPWD + set pathName [file join $fileDir $fileName] + } + + test filebox-2.2 "$command command" { + ToPressButton $parent ok + set choice [$command -title "Press Ok" \ + -parent $parent -initialfile $fileName -initialdir $fileDir] + } $pathName + + test filebox-2.3 "$command command" { + ToEnterFileByKey $parent $fileName $fileDir + set choice [$command -title "Enter \"$fileName\" and press Ok" \ + -parent $parent -initialdir $fileDir] + } $pathName + + set filters(1) {} + + set filters(2) { + {"Text files" {.txt .doc} } + {"Text files" {} TEXT} + {"Tcl Scripts" {.tcl} TEXT} + {"C Source Files" {.c .h} } + {"All Source Files" {.tcl .c .h} } + {"Image Files" {.gif} } + {"Image Files" {.jpeg .jpg} } + {"Image Files" "" {GIFF JPEG}} + {"All files" *} + } + + set filters(3) { + {"Text files" {.txt .doc} TEXT} + {"Foo" {""} TEXT} + } + + foreach x [lsort -integer [array names filters]] { + test filebox-3.$x "$command command" { + ToPressButton $parent ok + set choice [$command -title "Press Ok" -filetypes $filters($x)\ + -parent $parent -initialfile $fileName -initialdir $fileDir] + } $pathName + } + + # + # 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 + # needed on the other platforms because they use native file dialogs. + # + + + + + # end inner if + } + + # end outer if +} + +set tk_strictMotif $tk_strictMotif_old + +if {$isNative && ![info exists INTERACTIVE]} { + puts " Some tests were skipped because they could not be performed" + puts " automatically on this platform. If you wish to execute them" + puts " interactively, set the TCL variable INTERACTIVE and re-run" + puts " the test." + return +} diff --git a/tests/focus.test b/tests/focus.test new file mode 100644 index 0000000..4aa4da3 --- /dev/null +++ b/tests/focus.test @@ -0,0 +1,630 @@ +# This file is a Tcl script to test out the "focus" command and the +# other procedures in the file tkFocus.c. It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) focus.test 1.24 97/08/11 09:39:34 + +if {$tcl_platform(platform) != "unix"} { + return +} + +if {[info procs test] != "test"} { + source defs +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +button .b -text .b -relief raised -bd 2 +pack .b + +proc focusSetup {} { + catch {destroy .t} + toplevel .t + wm geom .t +0+0 + foreach i {b1 b2 b3 b4} { + button .t.$i -text .t.$i -relief raised -bd 2 + pack .t.$i + } + tkwait visibility .t.b4 +} +proc focusSetupAlt {} { + global env + catch {destroy .alt} + toplevel .alt -screen $env(TK_ALT_DISPLAY) + wm withdraw .alt + foreach i {a b c d} { + button .alt.$i -text .alt.$i -relief raised -bd 2 + pack .alt.$i + } + tkwait visibility .alt.d +} + +# Make sure the window manager knows who has focus +fixfocus + +# The following procedure ensures that there is no input focus +# in this application. It does it by arranging for another +# application to grab the focus. The "after" and "update" stuff +# is needed to wait long enough for pending actions to get through +# the X server and possibly also the window manager. + +setupbg +proc focusClear {} { + global x; + after 200 {set x 1} + tkwait variable x + dobg {focus -force .; update} + update +} + +focusSetup +set altDisplay [info exists env(TK_ALT_DISPLAY)] +if $altDisplay { + focusSetupAlt +} +update + +bind all <FocusIn> { + append focusInfo "in %W %d\n" +} +bind all <FocusOut> { + append focusInfo "out %W %d\n" +} +bind all <KeyPress> { + append focusInfo "press %W %K" +} + +test focus-1.1 {Tk_FocusCmd procedure} { + focusClear + focus +} {} +if $altDisplay { + test focus-1.2 {Tk_FocusCmd procedure} { + focus .alt.b + focus + } {} +} +test focus-1.3 {Tk_FocusCmd procedure} { + focusClear + focus .t.b3 + focus +} {} +test focus-1.4 {Tk_FocusCmd procedure} { + list [catch {focus ""} msg] $msg +} {0 {}} +test focus-1.5 {Tk_FocusCmd procedure} { + focusClear + focus -force .t + focus .t.b3 + focus +} {.t.b3} +test focus-1.6 {Tk_FocusCmd procedure} { + list [catch {focus .gorp} msg] $msg +} {1 {bad window path name ".gorp"}} +test focus-1.7 {Tk_FocusCmd procedure} { + 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} { + toplevel .t2 + wm geom .t2 +10+10 + frame .t2.f -width 200 -height 100 -bd 2 -relief raised + frame .t2.f2 -width 200 -height 100 -bd 2 -relief raised + pack .t2.f .t2.f2 + bind .t2.f <Destroy> {focus .t2.f} + bind .t2.f2 <Destroy> {focus .t2} + focus -force .t2.f2 + tkwait visibility .t2.f2 + update + set x [focus] + destroy .t2.f2 + lappend x [focus] + destroy .t2.f + lappend x [focus] + destroy .t2 + set x +} {.t2.f2 .t2 .t2} +test focus-1.9 {Tk_FocusCmd procedure, -displayof option} { + list [catch {focus -displayof} msg] $msg +} {1 {wrong # args: should be "focus -displayof window"}} +test focus-1.10 {Tk_FocusCmd procedure, -displayof option} { + 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} { + list [catch {focus -displayof .lousy} msg] $msg +} {1 {bad window path name ".lousy"}} +test focus-1.12 {Tk_FocusCmd procedure, -displayof option} { + focusClear + focus .t + focus -displayof .t.b3 +} {} +test focus-1.13 {Tk_FocusCmd procedure, -displayof option} { + focusClear + focus -force .t + focus -displayof .t.b3 +} {.t} +if $altDisplay { + test focus-1.14 {Tk_FocusCmd procedure, -displayof option} { + focus -force .alt.c + focus -displayof .alt + } {.alt.c} +} +test focus-1.15 {Tk_FocusCmd procedure, -force option} { + list [catch {focus -force} msg] $msg +} {1 {wrong # args: should be "focus -force window"}} +test focus-1.16 {Tk_FocusCmd procedure, -force option} { + 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} { + list [catch {focus -force foo} msg] $msg +} {1 {bad window path name "foo"}} +test focus-1.18 {Tk_FocusCmd procedure, -force option} { + list [catch {focus -force ""} msg] $msg +} {0 {}} +test focus-1.19 {Tk_FocusCmd procedure, -force option} { + 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} { + list [catch {focus -lastfor} msg] $msg +} {1 {wrong # args: should be "focus -lastfor window"}} +test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} { + 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} { + list [catch {focus -lastfor who_knows?} msg] $msg +} {1 {bad window path name "who_knows?"}} +test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} { + focus .b + focus .t.b1 + list [focus -lastfor .] [focus -lastfor .t.b3] +} {.b .t.b1} +test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} { + destroy .t + focusSetup + update + focus -lastfor .t.b2 +} {.t} +test focus-1.25 {Tk_FocusCmd procedure} { + list [catch {focus -unknown} msg] $msg +} {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}} + +test focus-2.1 {TkFocusFilterEvent procedure} {nonPortable} { + focus -force .b + destroy .t + focusSetup + update + set focusInfo {} + event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor -sendevent 0x54217567 + list $focusInfo +} {{}} +test focus-2.2 {TkFocusFilterEvent procedure} {nonPortable} { + focus -force .b + destroy .t + focusSetup + update + set focusInfo {} + event gen .t <FocusIn> -detail NotifyAncestor -sendevent 0x547321ac + list $focusInfo [focus] +} {{in .t NotifyAncestor +} .b} +test focus-2.3 {TkFocusFilterEvent procedure} {nonPortable} { + focus -force .b + destroy .t + focusSetup + update + set focusInfo {} + event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor + update + list $focusInfo [focus -lastfor .t] +} {{out .b NotifyNonlinear +out . NotifyNonlinearVirtual +in .t NotifyNonlinear +} .t} +test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} {nonPortable} { + set result {} + focus .t.b1 + # Important to end with NotifyAncestor, which is an + # event that is processed normally. This has a side + # effect on text 2.5 + foreach detail {NotifyAncestor NotifyNonlinear + NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot + NotifyVirtual NotifyAncestor} { + focus -force . + update + event gen [testwrapper .t] <FocusIn> -detail $detail + set focusInfo {} + update + lappend result $focusInfo + } + set result +} {{out . NotifyNonlinear +in .t NotifyNonlinearVirtual +in .t.b1 NotifyNonlinear +} {out . NotifyNonlinear +in .t NotifyNonlinearVirtual +in .t.b1 NotifyNonlinear +} {} {out . NotifyNonlinear +in .t NotifyNonlinearVirtual +in .t.b1 NotifyNonlinear +} {} {} {out . NotifyNonlinear +in .t NotifyNonlinearVirtual +in .t.b1 NotifyNonlinear +}} +test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} {nonPortable} { + focusSetup + focus .t.b1 + update + event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor + list $focusInfo [focus] +} {{out . NotifyNonlinear +in .t NotifyNonlinearVirtual +in .t.b1 NotifyNonlinear +} .t.b1} +test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} { + focus .t.b1 + focus . + update + event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor + set focusInfo {} + set x [focus] + event gen . <KeyPress-x> + list $x $focusInfo +} {.t.b1 {press .t.b1 x}} +test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} { + set result {} + foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear + NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot + NotifyVirtual} { + focus -force .t.b1 + event gen [testwrapper .t] <FocusOut> -detail $detail + update + lappend result [focus] + } + set result +} {{} .t.b1 {} {} .t.b1 .t.b1 {}} +test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} { + focus -force .t.b1 + event gen .t.b1 <FocusOut> -detail NotifyAncestor + focus +} {.t.b1} +test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} { + focus .t.b1 + event gen [testwrapper .] <FocusOut> -detail NotifyAncestor + focus +} {} +test focus-2.10 {TkFocusFilterEvent procedure, Enter events} { + set result {} + focus .t.b1 + focusClear + foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear + NotifyNonlinearVirtual NotifyVirtual} { + event gen [testwrapper .t] <Enter> -detail $detail -focus 1 + update + lappend result [focus] + event gen [testwrapper .t] <Leave> -detail NotifyAncestor + update + } + set result +} {.t.b1 {} .t.b1 .t.b1 .t.b1} +test focus-2.11 {TkFocusFilterEvent procedure, Enter events} { + focusClear + set focusInfo {} + event gen [testwrapper .t] <Enter> -detail NotifyAncestor + update + set focusInfo +} {} +test focus-2.12 {TkFocusFilterEvent procedure, Enter events} { + focus -force .b + update + set focusInfo {} + event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 + update + set focusInfo +} {} +test focus-2.13 {TkFocusFilterEvent procedure, Enter events} { + focus .t.b1 + focusClear + event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 + set focusInfo {} + update + set focusInfo +} {in .t NotifyVirtual +in .t.b1 NotifyAncestor +} +test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} { + focusClear + catch {destroy .t2} + toplevel .t2 + wm withdraw .t2 + update + set focusInfo {} + event gen [testwrapper .t2] <Enter> -detail NotifyAncestor -focus 1 + update + destroy .t2 +} {} +test focus-2.15 {TkFocusFilterEvent procedure, Leave events} { + set result {} + focus .t.b1 + foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear + NotifyNonlinearVirtual NotifyVirtual} { + focusClear + event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 + update + event gen [testwrapper .t] <Leave> -detail $detail + update + lappend result [focus] + } + set result +} {{} .t.b1 {} {} {}} +test focus-2.16 {TkFocusFilterEvent procedure, Leave events} { + set result {} + focus .t.b1 + event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 + update + set focusInfo {} + event gen [testwrapper .t] <Leave> -detail NotifyAncestor + update + set focusInfo +} {out .t.b1 NotifyAncestor +out .t NotifyVirtual +} +test focus-2.17 {TkFocusFilterEvent procedure, Leave events} { + set result {} + focus .t.b1 + event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 + update + set focusInfo {} + event gen .t.b1 <Leave> -detail NotifyAncestor + event gen [testwrapper .] <Leave> -detail NotifyAncestor + update + list $focusInfo [focus] +} {{out .t.b1 NotifyAncestor +out .t NotifyVirtual +} {}} + +test focus-3.1 {SetFocus procedure, create record on focus} { + toplevel .t2 -width 250 -height 100 + wm geometry .t2 +0+0 + update + focus -force .t2 + update + focus +} {.t2} +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} { + update + button .b2 -text "Another button" + focus .b2 + update +} {} +catch {destroy .b2} +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} { + focusSetup + focus -force .t.b2 + update +} {} +test focus-3.4 {SetFocus procedure, delaying claim of X focus} { + focusSetup + wm withdraw .t + focus -force .t.b2 + toplevel .t2 -width 250 -height 100 + wm geometry .t2 +10+10 + focus -force .t2 + wm withdraw .t2 + update + wm deiconify .t2 + wm deiconify .t +} {} +catch {destroy .t2} +test focus-3.5 {SetFocus procedure, generating events} { + focusSetup + focusClear + set focusInfo {} + focus -force .t.b2 + update + set focusInfo +} {in .t NotifyVirtual +in .t.b2 NotifyAncestor +} +test focus-3.6 {SetFocus procedure, generating events} { + focusSetup + focus -force .b + update + set focusInfo {} + focus .t.b2 + update + set focusInfo +} {out .b NotifyNonlinear +out . NotifyNonlinearVirtual +in .t NotifyNonlinearVirtual +in .t.b2 NotifyNonlinear +} +test focus-3.7 {SetFocus procedure, generating events} {nonPortable} { + # Non-portable because some platforms generate extra events. + + focusSetup + focusClear + set focusInfo {} + focus .t.b2 + update + set focusInfo +} {} + +test focus-4.1 {TkFocusDeadWindow procedure} { + focusSetup + update + focus -force .b + update + destroy .t + focus +} {.b} +test focus-4.2 {TkFocusDeadWindow procedure} { + focusSetup + update + focus -force .t.b2 + focus .b + update + destroy .t.b2 + update + focus +} {.b} + +# Non-portable due to wm-specific redirection of input focus when +# windows are deleted: + +test focus-4.3 {TkFocusDeadWindow procedure} {nonPortable} { + focusSetup + update + focus .t + update + destroy .t + update + focus +} {} +test focus-4.4 {TkFocusDeadWindow procedure} { + focusSetup + focus -force .t.b2 + update + destroy .t.b2 + focus +} {.t} + +# I don't know how to test most of the remaining procedures of this file +# explicitly; they've already been exercised by the preceding tests. + +test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} { + focusSetup + focus -force .t + update + set result [focus] + send [dobg {tk appname}] {focus -force .; update} + lappend result [focus] + focus .t.b2 + update + lappend result [focus] +} {.t .t {}} + +catch {destroy .t} +bind all <FocusIn> {} +bind all <FocusOut> {} +bind all <KeyPress> {} +cleanupbg +fixfocus + +test focus-6.1 {miscellaneous - embedded application in same process} {unixOnly} { + eval interp delete [interp slaves] + catch {destroy .t} + toplevel .t + wm geometry .t +0+0 + frame .t.f1 -container 1 + frame .t.f2 + pack .t.f1 .t.f2 + entry .t.f2.e1 -bg red + pack .t.f2.e1 + bind all <FocusIn> {lappend x "focus in %W %d"} + bind all <FocusOut> {lappend x "focus out %W %d"} + interp create child + child eval "set argv {-use [winfo id .t.f1]}" + load {} tk child + child eval { + entry .e1 -bg lightBlue + pack .e1 + bind all <FocusIn> {lappend x "focus in %W %d"} + bind all <FocusOut> {lappend x "focus out %W %d"} + set x {} + } + + # Claim the focus and wait long enough for it to really arrive. + + focus -force .t.f2.e1 + after 300 {set timer 1} + vwait timer + set x {} + lappend x [focus] [child eval focus] + + # See if a "focus" command will move the focus to the embedded + # application. + + child eval {focus .e1} + after 300 {set timer 1} + vwait timer + lappend x | + child eval {lappend x |} + + # Bring the focus back to the main application. + + focus .t.f2.e1 + after 300 {set timer 1} + vwait timer + set result [list $x [child eval {set x}]] + interp delete child + 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} { + eval interp delete [interp slaves] + catch {destroy .t} + setupbg + toplevel .t + wm geometry .t +0+0 + frame .t.f1 -container 1 + frame .t.f2 + pack .t.f1 .t.f2 + entry .t.f2.e1 -bg red + pack .t.f2.e1 + bind all <FocusIn> {lappend x "focus in %W %d"} + bind all <FocusOut> {lappend x "focus out %W %d"} + setupbg -use [winfo id .t.f1] + dobg { + entry .e1 -bg lightBlue + pack .e1 + bind all <FocusIn> {lappend x "focus in %W %d"} + bind all <FocusOut> {lappend x "focus out %W %d"} + set x {} + } + + # Claim the focus and wait long enough for it to really arrive. + + focus -force .t.f2.e1 + after 300 {set timer 1} + vwait timer + set x {} + lappend x [focus] [dobg focus] + + # See if a "focus" command will move the focus to the embedded + # application. + + dobg {focus .e1} + after 300 {set timer 1} + vwait timer + lappend x | + dobg {lappend x |} + + # Bring the focus back to the main application. + + focus .t.f2.e1 + after 300 {set timer 1} + vwait timer + set result [list $x [dobg {set x}]] + cleanupbg + 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}}} + +eval destroy [winfo children .] +bind all <FocusIn> {} +bind all <FocusOut> {} diff --git a/tests/focusTcl.test b/tests/focusTcl.test new file mode 100644 index 0000000..2154041 --- /dev/null +++ b/tests/focusTcl.test @@ -0,0 +1,279 @@ +# This file is a Tcl script to test out the features of the script +# file focus.tcl, which includes the procedures tk_focusNext and +# tk_focusPrev, among other things. This file is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) focusTcl.test 1.7 96/09/26 10:25:58 + +if {[info procs test] != "test"} { + source defs +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +proc setup1 w { + if {$w == "."} { + set w "" + } + foreach i {a b c d} { + frame $w.$i -width 100 -height 50 -bd 2 -relief raised + pack $w.$i + } + .b configure -width 0 -height 0 + foreach i {x y z} { + button $w.b.$i -text "Button $w.b.$i" + pack $w.b.$i -side left + } + tkwait visibility $w.b.z +} + +option add *takeFocus 1 +option add *highlightThickness 2 +. configure -takefocus 1 -highlightthickness 2 +test focusTcl-1.1 {tk_focusNext procedure, no children} { + tk_focusNext . +} {.} +setup1 . +test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext . +} {.a} +test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext .a +} {.b} +test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext .b +} {.b.x} +test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext .b.x +} {.b.y} +test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext .b.y +} {.b.z} +test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext .b.z +} {.c} +test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext .c +} {.d} +test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext .d +} {.} +foreach w {.b .b.x .b.y .c .d} { + $w configure -takefocus 0 +} +test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext .a +} {.b.z} +test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} { + tk_focusNext .b.z +} {.} +test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} { + eval destroy [winfo child .] + setup1 . + update + . configure -takefocus 0 + tk_focusNext .d +} {.a} +. configure -takefocus 1 + +eval destroy [winfo child .] +setup1 . +toplevel .t +wm geom .t +0+0 +toplevel .t2 +wm geom .t2 -0+0 +raise .t .a +test focusTcl-2.1 {tk_focusNext procedure, toplevels} { + tk_focusNext .a +} {.b} +test focusTcl-2.2 {tk_focusNext procedure, toplevels} { + tk_focusNext .d +} {.} +test focusTcl-2.3 {tk_focusNext procedure, toplevels} { + tk_focusNext .t +} {.t} +setup1 .t +raise .t.b +test focusTcl-2.4 {tk_focusNext procedure, toplevels} { + tk_focusNext .t +} {.t.a} +test focusTcl-2.5 {tk_focusNext procedure, toplevels} { + tk_focusNext .t.b.z +} {.t} + +eval destroy [winfo child .] +test focusTcl-3.1 {tk_focusPrev procedure, no children} { + tk_focusPrev . +} {.} +setup1 . +test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} { + tk_focusPrev . +} {.d} +test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} { + tk_focusPrev .d +} {.c} +test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} { + tk_focusPrev .c +} {.b.z} +test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} { + tk_focusPrev .b.z +} {.b.y} +test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} { + tk_focusPrev .b.y +} {.b.x} +test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} { + tk_focusPrev .b.x +} {.b} +test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} { + tk_focusPrev .b +} {.a} +test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} { + tk_focusPrev .a +} {.} + +eval destroy [winfo child .] +setup1 . +toplevel .t +wm geom .t +0+0 +toplevel .t2 +wm geom .t2 -0+0 +raise .t .a +test focusTcl-4.1 {tk_focusPrev procedure, toplevels} { + tk_focusPrev . +} {.d} +test focusTcl-4.2 {tk_focusPrev procedure, toplevels} { + tk_focusPrev .b +} {.a} +test focusTcl-4.3 {tk_focusPrev procedure, toplevels} { + tk_focusPrev .t +} {.t} +setup1 .t +update +.t configure -takefocus 0 +raise .t.b +test focusTcl-4.4 {tk_focusPrev procedure, toplevels} { + tk_focusPrev .t +} {.t.b.z} +test focusTcl-4.5 {tk_focusPrev procedure, toplevels} { + tk_focusPrev .t.a +} {.t.b.z} + +eval destroy [winfo child .] +test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} { + eval destroy [winfo child .] + setup1 . + .b.x configure -takefocus 0 + tk_focusNext .b +} {.b.y} +test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} { + eval destroy [winfo child .] + setup1 . + pack forget .b + update + .b configure -takefocus "" + .b.y configure -takefocus "" + .b.z configure -takefocus "" + list [tk_focusNext .a] [tk_focusNext .b.x] +} {.c .c} +test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} { + proc t w { + if {$w == ".b.x"} { + return 1 + } elseif {$w == ".b.y"} { + return "" + } + return 0 + } + eval destroy [winfo child .] + setup1 . + pack forget .b.y + update + .b configure -takefocus "" + foreach w {.b.x .b.y .b.z .c} { + $w configure -takefocus t + } + list [tk_focusNext .a] [tk_focusNext .b.x] +} {.b.x .d} +test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} { + eval destroy [winfo child .] + setup1 . + .b.x configure -takefocus "" + update + tk_focusNext .b +} {.b.x} +test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} { + eval destroy [winfo child .] + setup1 . + .b.x configure -takefocus "" + pack unpack .b.x + update + tk_focusNext .b +} {.b.y} +test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} { + eval destroy [winfo child .] + setup1 . + foreach w {.b.x .b.y .b.z} { + $w configure -takefocus "" + } + pack unpack .b + update + tk_focusNext .b +} {.c} +test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} { + eval destroy [winfo child .] + setup1 . + .b.y configure -takefocus 1 + pack unpack .b.y + update + tk_focusNext .b.x +} {.b.z} +test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} { + proc always args {return 1} + eval destroy [winfo child .] + setup1 . + .b.y configure -takefocus always + pack unpack .b.y + update + tk_focusNext .b.x +} {.b.y} +test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} { + eval destroy [winfo child .] + setup1 . + foreach w {.b.x .b.y .b.z} { + $w configure -takefocus "" + } + update + .b.x configure -state disabled + tk_focusNext .b +} {.b.y} +test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} { + eval destroy [winfo child .] + setup1 . + foreach w {.a .b .c .d} { + $w configure -takefocus "" + } + update + bind .a <Key> {foo} + list [tk_focusNext .] [tk_focusNext .a] +} {.a .b.x} +test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} { + eval destroy [winfo child .] + setup1 . + foreach w {.a .b .c .d} { + $w configure -takefocus "" + } + update + bind Frame <Key> {foo} + list [tk_focusNext .] [tk_focusNext .a] +} {.a .b} + +bind Frame <Key> {} +. configure -takefocus 0 -highlightthickness 0 +option clear diff --git a/tests/font.test b/tests/font.test new file mode 100644 index 0000000..a526470 --- /dev/null +++ b/tests/font.test @@ -0,0 +1,1092 @@ +# This file is a Tcl script to test out Tk's "font" command +# plus the procedures in tkFont.c. It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) font.test 1.22 97/10/10 14:34:54 + +if {[string compare test [info procs test]] != 0} { + source defs +} + +catch {destroy .b} +toplevel .b +wm geom .b +0+0 +update idletasks + +proc setup {} { + catch {destroy .b.f} + catch {font delete xyz} + label .b.f + pack .b.f + update +} + +label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Helvetica -12 bold" +pack .b.l +canvas .b.c -closeenough 0 +.b.c create text 0 0 -tags text -anchor nw -just left -font "Helvetica -12 bold" +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]" +} + +proc csetup {{str ""}} { + focus -force .b.c + .b.c dchars text 0 end + .b.c insert text 0 $str + .b.c focus text +} + +setup + +case $tcl_platform(platform) { + unix {set fixed "fixed"} + windows {set fixed "courier 12"} + macintosh {set fixed "monaco 9"} +} +set times [font actual {times 0} -family] + +test font-1.1 {font command: general} { + list [catch {font} msg] $msg +} {1 {wrong # args: should be "font option ?arg?"}} +test font-1.2 {font command: actual: arguments} { + list [catch {font actual xyz -displayof} msg] $msg +} {1 {value for "-displayof" missing}} +test font-1.3 {font command: actual: arguments} { + list [catch {font actual} msg] $msg +} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} +test font-1.4 {font command: actual: arguments} { + list [catch {font actual xyz abc def} msg] $msg +} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} +test font-1.5 {font command: actual: arguments} { + list [catch {font actual {}} msg] $msg +} {1 {font "" doesn't exist}} +test font-1.6 {font command: actual: displayof specified, so skip to next} { + catch {font actual xyz -displayof . -size} +} {0} +test font-1.7 {font command: actual: displayof specified, so skip to next} { + lindex [font actual xyz -displayof .] 0 +} {-family} +test font-1.8 {font command: actual} {unix || mac} { + string tolower [font actual {-family times} -family] +} {times} +test font-1.9 {font command: actual} {pcOnly} { + font actual {-family times} -family +} {Times New Roman} +test font-1.10 {font command: actual} { + lindex [font actual {-family times}] 0 +} {-family} +test font-1.11 {font command: bad option} { + list [catch {font actual xyz -style} msg] $msg +} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} + +test font-2.1 {font command: configure} { + list [catch {font configure} msg] $msg +} {1 {wrong # args: should be "font configure fontname ?options?"}} +test font-2.2 {font command: configure: non-existent font} { + list [catch {font configure xyz} msg] $msg +} {1 {named font "xyz" doesn't exist}} +test font-2.3 {font command: configure: "deleted" font} { + setup + font create xyz + .b.f configure -font xyz + font delete xyz + list [catch {font configure xyz} msg] $msg +} {1 {named font "xyz" doesn't exist}} +test font-2.4 {font command: configure: get all options} { + setup + font create xyz -family xyz + lindex [font configure xyz] 1 +} xyz +test font-2.5 {font command: configure: get one option} { + setup + font create xyz -family xyz + font configure xyz -family +} xyz +test font-2.6 {font command: configure: update existing font} { + setup + font create xyz + font configure xyz -family xyz + update + font configure xyz -family +} xyz +test font-2.7 {font command: configure: bad option} { + setup + font create xyz + list [catch {font configure xyz -style} msg] $msg +} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} + +test font-3.1 {font command: create: make up name} { + font delete [font create] + font delete [font create -family xyz] +} {} +test font-3.2 {font command: create: already exists} { + setup + font create xyz + list [catch {font create xyz} msg] $msg +} {1 {font "xyz" already exists}} +test font-3.3 {font command: create: error recreating "deleted" font} { + setup + font create xyz + .b.f configure -font xyz + font delete xyz + list [catch {font create xyz -xyz times} msg] $msg +} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +test font-3.4 {font command: create: recreate "deleted" font} { + setup + font create xyz + .b.f configure -font xyz + font delete xyz + font actual xyz + font create xyz -family times + update + font configure xyz -family +} {times} +test font-3.5 {font command: create: bad option creating new font} { + setup + list [catch {font create xyz -xyz times} msg] $msg +} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +test font-3.6 {font command: create: totally new font} { + setup + font create xyz -family xyz + font configure xyz -family +} {xyz} + +test font-4.1 {font command: delete: arguments} { + list [catch {font delete} msg] $msg +} {1 {wrong # args: should be "font delete fontname ?fontname ...?"}} +test font-4.2 {font command: delete: loop test} { + font create a -underline 1 + font create b -underline 1 + font create c -underline 1 + font delete a b c + list [font actual a -underline] [font actual b -underline] [font actual c -underline] +} {0 0 0} +test font-4.3 {font command: delete: non-existent} { + setup + list [catch {font delete xyz} msg] $msg +} {1 {named font "xyz" doesn't exist}} +test font-4.4 {font command: delete: mark for later deletion} { + setup + font create xyz + .b.f configure -font xyz + font delete xyz + font actual xyz + list [catch {font configure xyz} msg] $msg +} {1 {named font "xyz" doesn't exist}} +test font-4.5 {font command: delete: actually delete} { + setup + font create xyz -underline 1 + font delete xyz + font actual xyz -underline +} {0} + +test font-5.1 {font command: families: arguments} { + list [catch {font families -displayof} msg] $msg +} {1 {value for "-displayof" missing}} +test font-5.2 {font command: families: arguments} { + list [catch {font families xyz} msg] $msg +} {1 {wrong # args: should be "font families ?-displayof window?"}} +test font-5.3 {font command: families} { + font families + set x {} +} {} + +test font-6.1 {font command: measure: arguments} { + list [catch {font measure xyz -displayof} msg] $msg +} {1 {value for "-displayof" missing}} +test font-6.2 {font command: measure: arguments} { + list [catch {font measure} msg] $msg +} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} +test font-6.3 {font command: measure: arguments} { + list [catch {font measure xyz abc def} msg] $msg +} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} +test font-6.4 {font command: measure: arguments} { + list [catch {font measure {} abc} msg] $msg +} {1 {font "" doesn't exist}} +test font-6.5 {font command: measure} { + expr [font measure $fixed "abcdefg"]==[font measure $fixed "a"]*7 +} {1} + +test font-7.1 {font command: metrics: arguments} { + list [catch {font metrics xyz -displayof} msg] $msg +} {1 {value for "-displayof" missing}} +test font-7.2 {font command: metrics: arguments} { + list [catch {font metrics} msg] $msg +} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} +test font-7.3 {font command: metrics: get all metrics} { + catch {unset a} + array set a [font metrics {-family xyz}] + set x [lsort [array names a]] + unset a + set x +} {-ascent -descent -fixed -linespace} +test font-7.4 {font command: metrics: get ascent} { + catch {expr [font metrics $fixed -ascent]} +} {0} +test font-7.5 {font command: metrics: get descent} { + catch {expr [font metrics {-family xyz} -descent]} +} {0} +test font-7.6 {font command: metrics: get linespace} { + catch {expr [font metrics {-family fixed} -linespace]} +} {0} +test font-7.7 {font command: metrics: get fixed} { + catch {expr [font metrics {-family fixed} -fixed]} +} {0} +test font-7.8 {font command: metrics: get ascent} { + catch {expr [font metrics {-family xyz} -ascent]} +} {0} +test font-7.9 {font command: metrics: get descent} { + catch {expr [font metrics {-family xyz} -descent]} +} {0} +test font-7.10 {font command: metrics: get linespace} { + catch {expr [font metrics {-family fixed} -linespace]} +} {0} +test font-7.11 {font command: metrics: get fixed} { + catch {expr [font metrics {-family fixed} -fixed]} +} {0} +test font-7.12 {font command: metrics: bad metric} { + list [catch {font metrics {-family fixed} -xyz} msg] $msg +} {1 {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}} + +test font-8.1 {font command: names: arguments} { + list [catch {font names xyz} msg] $msg +} {1 {wrong # args: should be "font names"}} +test font-8.2 {font command: names} { + setup + font create xyz + font create abc + set x [lsort [font names]] + font delete abc + font delete xyz + set x +} {abc xyz} +test font-8.3 {font command: names} { + setup + font create xyz + font create abc + set x [lsort [font names]] + .b.f config -font xyz + font delete xyz + lappend x [font names] + font delete abc + set x +} {abc xyz abc} + +test font-9.1 {font command: unknown option} { + list [catch {font xyz} msg] $msg +} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} + +test font-10.1 {UpdateDependantFonts procedure: no users} { + setup + font create xyz + font configure xyz -family times +} {} +test font-10.2 {UpdateDependantFonts procedure: pings the widgets} { + setup + font create xyz -family times -size 20 + .b.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 + set a1 [font measure xyz "abcd"] + update + set b1 [winfo reqwidth .b.f] + font configure xyz -family helvetica -size 20 + set a2 [font measure xyz "abcd"] + update + set b2 [winfo reqwidth .b.f] + expr {$a1==$b1 && $a2==$b2} +} {1} + +test font-11.1 {Tk_GetFont procedure: bump ref count} { + setup + .b.f config -font {-family fixed} + lindex [font actual {-family fixed}] 0 +} {-family} +test font-11.2 {Tk_GetFont procedure: bump ref count of named font, too} { + setup + font create xyz + .b.f config -font xyz + lindex [font actual xyz] 0 +} {-family} +test font-11.3 {Tk_GetFont procedure: get named font} { + setup + font create xyz + .b.f config -font xyz +} {} +test font-11.4 {Tk_GetFont procedure: get native font} {unixOnly} { + setup + .b.f config -font fixed +} {} +test font-11.5 {Tk_GetFont procedure: get native font} {pcOnly} { + setup + .b.f config -font oemfixed +} {} +test font-11.6 {Tk_GetFont procedure: get native font} {macOnly} { + setup + .b.f config -font application +} {} +test font-11.7 {Tk_GetFont procedure: get attribute font} { + list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg +} {1 {expected integer but got "yyy"}} +test font-11.8 {Tk_GetFont procedure: get attribute font} { + lindex [font actual {plan 9}] 0 +} {-family} +test font-11.9 {Tk_GetFont procedure: no match} { + list [catch {font actual {}} msg] $msg +} {1 {font "" doesn't exist}} + +test font-12.1 {Tk_NameOfFont procedure} { + setup + .b.f config -font {-family fixed} + .b.f cget -font +} {-family fixed} + +test font-13.1 {Tk_FreeFont procedure: one ref} { + setup + .b.f config -font {-family fixed} + destroy .b.f +} {} +test font-13.2 {Tk_FreeFont procedure: multiple ref} { + setup + .b.f config -font {-family fixed} + button .b.b -font {-family fixed} + destroy .b.f + set x [.b.b cget -font] + destroy .b.b + set x +} {-family fixed} +test font-13.3 {Tk_FreeFont procedure: named font} { + setup + font create xyz + .b.f config -font xyz + destroy .b.f + font names +} {xyz} +test font-13.4 {Tk_FreeFont procedure: named font} { + setup + font create xyz -underline 1 + .b.f config -font xyz + font delete xyz + set x [font actual xyz -underline] + destroy .b.f + list [font actual xyz -underline] $x +} {0 1} +test font-13.5 {Tk_FreeFont procedure: named font not deleted yet} { + setup + font create xyz + .b.f config -font xyz + button .b.b -font xyz + font delete xyz + set x [font actual xyz] + destroy .b.b + list [lindex [font actual xyz] 0] [lindex $x 0] +} {-family -family} + +test font-14.1 {Tk_FontId} { + .b.f config -font "times 20" + update +} {} + +test font-15.1 {Tk_FontMetrics procedure} { + button .b.w1 -text abc + entry .b.w2 -text abcd + update + destroy .b.w1 .b.w2 +} {} + +proc psfontname {name} { + set a [.b.c itemcget text -font] + .b.c itemconfig text -font $name + set post [.b.c postscript] + .b.c itemconfig text -font $a + set end [string first "findfont" $post] + incr end -2 + set post [string range $post [expr $end-70] $end] + set start [string first "gsave" $post] + return [string range $post [expr $start+7] end] +} +test font-16.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { + set x [font actual {{itc avant garde} 10} -family] + if {[string match *avant*garde $x]} { + psfontname "{itc avant garde} 10" + } else { + set x {AvantGarde-Book} + } +} {AvantGarde-Book} +test font-16.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { + psfontname "arial 10" +} {Helvetica} +test font-16.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { + psfontname "{times new roman} 10" +} {Times-Roman} +test font-16.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { + psfontname "{courier new} 10" +} {Courier} +test font-16.5 {Tk_PostscriptFontName procedure: native} {macOnly} { + psfontname "geneva 10" +} {Helvetica} +test font-16.6 {Tk_PostscriptFontName procedure: native} {macOnly} { + psfontname "{new york} 10" +} {Times-Roman} +test font-16.7 {Tk_PostscriptFontName procedure: native} {macOnly} { + psfontname "monaco 10" +} {Courier} +test font-16.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { + set x [font actual {{lucida bright} 10} -family] + if {[string match lucida*bright $x]} { + psfontname "{lucida bright} 10" + } else { + set x {LucidaBright} + } +} {LucidaBright} +test font-16.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { + 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} +} { + test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} { + set family [lindex $p 0] + set x {} + set i 1 + 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] + } + incr i + } + } + incr i + set x + } [lrange $p 1 end] +} +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} +} { + test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} { + 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] +} +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-16.$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] +} + +test font-17.1 {Tk_UnderlineChars procedure} { + text .b.t + .b.t insert 1.0 abc\tdefg + .b.t tag config sel -underline 1 + .b.t tag add sel 1.0 end + update +} {} + +setup +test font-18.1 {Tk_ComputeTextLayout: empty string} { + .b.l config -text "" +} {} +test font-18.2 {Tk_ComputeTextLayout: simple string} { + .b.l config -text "000" + getsize +} "[expr $ax*3] $ay" +test font-18.3 {Tk_ComputeTextLayout: find special chars} { + .b.l config -text "000\n000" + getsize +} "[expr $ax*3] [expr $ay*2]" +test font-18.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { + .b.l config -text "000\n000" + getsize +} "[expr $ax*3] [expr $ay*2]" +test font-18.5 {Tk_ComputeTextLayout: break line} { + .b.l config -text "000\t00000" -wrap [expr 9*$ax] + set x [getsize] + .b.l config -wrap 0 + set x +} "[expr 8*$ax] [expr 2*$ay]" +test font-18.6 {Tk_ComputeTextLayout: normal ended on special char} { + .b.l config -text "000\n000" +} {} +test font-18.7 {Tk_ComputeTextLayout: special char was \n} { + .b.l config -text "000\n0000" + getsize +} "[expr $ax*4] [expr $ay*2]" +test font-18.8 {Tk_ComputeTextLayout: special char was \t} { + .b.l config -text "000\t00" + getsize +} "[expr $ax*10] $ay" +test font-18.9 {Tk_ComputeTextLayout: tab didn't cause break} { + set x {} + .b.l config -text "000\t000" + lappend x [getsize] + .b.l config -text "000\t000" -wrap [expr 100*$ax] + lappend x [getsize] + .b.l config -wrap 0 + set x +} "{[expr $ax*11] $ay} {[expr $ax*11] $ay}" +test font-18.10 {Tk_ComputeTextLayout: tab caused break} { + set x {} + .b.l config -text "000\t" + lappend x [getsize] + .b.l config -text "000\t00" -wrap [expr $ax*6] + lappend x [getsize] + .b.l config -wrap 0 + set x +} "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}" +test font-18.11 {Tk_ComputeTextLayout: absorb spaces at eol} { + set x {} + .b.l config -text "000 000" -wrap [expr $ax*5] + lappend x [getsize] + .b.l config -text "000 " + lappend x [getsize] + .b.l config -wrap 0 + set x +} "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}" +test font-18.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { + set x {} + .b.l config -text "000 0000" -wrap [expr $ax*5] + lappend x [getsize] + .b.l config -text "000\t00 0000" -wrap [expr $ax*12] + lappend x [getsize] + .b.l config -wrap 0 + set x +} "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}" +test font-18.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { + .b.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" + getsize +} "1 [expr $ay*129]" +test font-18.14 {Tk_ComputeTextLayout: text ended with \n} { + list [.b.l config -text "0000"; getsize] [.b.l config -text "0000\n"; getsize] +} "{[expr $ax*4] $ay} {[expr $ax*4] [expr $ay*2]}" +test font-18.15 {Tk_ComputeTextLayout: justification} { + csetup "000\n00000" + set x {} + .b.c itemconfig text -just left + lappend x [.b.c index text @[expr $ax*2],0] + .b.c itemconfig text -just center + lappend x [.b.c index text @[expr $ax*2],0] + .b.c itemconfig text -just right + lappend x [.b.c index text @[expr $ax*2],0] + .b.c itemconfig text -just left + set x +} {2 1 0} + +test font-19.1 {Tk_FreeTextLayout procedure} { + setup + .b.f config -text foo + .b.f config -text boo +} {} + +test font-20.1 {Tk_DrawTextLayout procedure: auto-detect last char} { + .b.f config -text foo +} {} +test font-20.2 {Tk_DrawTextLayout procedure: multiple chunks} { + csetup "000\t00\n000" +} {} +test font-20.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { + csetup "000\t00" + .b.c select from text 3 + .b.c select to text 5 +} {} +test font-20.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { + .b.c select from text 3 + .b.c select to text 5 +} {} +test font-20.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { + .b.c select from text 2 + .b.c select to text 2 +} {} +test font-20.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { + .b.c select from text 4 + .b.c select to text 4 +} {} + +test font-21.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { + .b.f config -text "foo" -under -1 +} {} +test font-21.2 {Tk_UnderlineTextLayout procedure: underline not visible} { + .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10 +} {} +test font-21.3 {Tk_UnderlineTextLayout procedure: underline is visible} { + .b.f config -text "000 00000" -wrap [expr $ax*7] -under 5 + .b.f config -wrap -1 -under -1 +} {} + +test font-22.1 {Tk_PointToChar procedure: above all lines} { + csetup "000" + .b.c index text @-1,0 +} {0} +test font-22.2 {Tk_PointToChar procedure: no chars} { + # After fixing the following bug: + # + # In canvas text item, it was impossible to click to position the + # insertion point just after the last character. + # + # introduced another bug that Tk_PointToChar() would return a character + # index of 1 if TextLayout contained 0 characters. + + csetup "" + .b.c index text @100,100 +} {0} +test font-22.3 {Tk_PointToChar procedure: loop test} { + csetup "000\n000\n000\n000" + .b.c index text @10000,0 +} {3} +test font-22.4 {Tk_PointToChar procedure: intersect line} { + csetup "000\n000\n000" + .b.c index text @0,$ay +} {4} +test font-22.5 {Tk_PointToChar procedure: to the left of all chunks} { + .b.c index text @-100,$ay +} {4} +test font-22.6 {Tk_PointToChar procedure: past any possible chunk} { + .b.c index text @100000,$ay +} {7} +test font-22.7 {Tk_PointToChar procedure: which chunk on this line} { + csetup "000\n000\t000\t000\n000" + .b.c index text @[expr $ax*2],$ay +} {6} +test font-22.8 {Tk_PointToChar procedure: which chunk on this line} { + csetup "000\n000\t000\t000\n000" + .b.c index text @[expr $ax*10],$ay +} {10} +test font-22.9 {Tk_PointToChar procedure: in special chunk} { + csetup "000\n000\t000\t000\n000" + .b.c index text @[expr $ax*6],$ay +} {7} +test font-22.10 {Tk_PointToChar procedure: past all chars in chunk} { + csetup "000 0000000" + .b.c itemconfig text -width [expr $ax*5] + set x [.b.c index text @[expr $ax*5],0] + .b.c itemconfig text -width 0 + set x +} {3} +test font-22.11 {Tk_PointToChar procedure: below all chunks} { + csetup "000 0000000" + .b.c index text @0,1000000 +} {11} + +test font-23.1 {Tk_CharBBox procedure: index < 0} { + .b.f config -text "000" -underline -1 +} {} +test font-23.2 {Tk_CharBBox procedure: loop} { + .b.f config -text "000\t000\t000\t000" -underline 9 +} {} +test font-23.3 {Tk_CharBBox procedure: special char} { + .b.f config -text "000\t000\t000" -underline 7 +} {} +test font-23.4 {Tk_CharBBox procedure: normal char} { + .b.f config -text "000" -underline 1 +} {} +test font-23.5 {Tk_CharBBox procedure: right edge of bbox truncated} { + .b.f config -text "0 0000" -wrap [expr $ax*4] -under 2 + .b.f config -wrap 0 +} {} +test font-23.6 {Tk_CharBBox procedure: bbox pegged to right edge} { + .b.f config -text "0 0000" -wrap [expr $ax*4] -under 3 + .b.f config -wrap 0 +} {} + +.b.c bind all <Enter> {lappend x [.b.c index current @%x,%y]} + +test font-24.1 {Tk_TextLayoutToPoint procedure: loop once} { + csetup "000\n000\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x 0 -y 0 + set x +} {0} +test font-24.2 {Tk_TextLayoutToPoint procedure: loop multiple} { + csetup "000\n000\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x $ax -y $ay + set x +} {5} +test font-24.3 {Tk_TextLayoutToPoint procedure: loop to end} { + csetup "000\n0\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x [expr $ax*2] -y $ay + set x +} {} +test font-24.4 {Tk_TextLayoutToPoint procedure: hit a special char (tab)} { + csetup "000\t000\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x [expr $ax*6] -y 0 + set x +} {3} +test font-24.5 {Tk_TextLayoutToPoint procedure: ignore newline} { + csetup "000\n0\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x [expr $ax*2] -y $ay + set x +} {} +test font-24.6 {Tk_TextLayoutToPoint procedure: ignore spaces at eol} { + csetup "000\n000 000000000" + .b.c itemconfig text -width [expr $ax*10] + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x [expr $ax*5] -y $ay + .b.c itemconfig text -width 0 + set x +} {} +.b.c itemconfig text -justify center +test font-24.7 {Tk_TextLayoutToPoint procedure: on left side} { + csetup "0\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x 0 -y 0 + set x +} {} +test font-24.8 {Tk_TextLayoutToPoint procedure: on right side} { + csetup "0\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x [expr $ax*2] -y 0 + set x +} {} +test font-24.9 {Tk_TextLayoutToPoint procedure: inside line} { + csetup "0\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x $ax -y 0 + set x +} {0} +test font-24.10 {Tk_TextLayoutToPoint procedure: above line} { + csetup "0\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x 0 -y 0 + set x +} {} +test font-24.11 {Tk_TextLayoutToPoint procedure: below line} { + csetup "000\n0" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x 0 -y $ay + set x +} {} +test font-24.12 {Tk_TextLayoutToPoint procedure: in line} { + csetup "0\n000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x $ax -y $ay + set x +} {3} +.b.c itemconfig text -justify left +test font-24.13 {Tk_TextLayoutToPoint procedure: exact hit} { + csetup "000" + set x {} + event generate .b.c <Leave> + event generate .b.c <Enter> -x $ax -y 0 + set x +} {1} + +test font-25.1 {Tk_TextLayoutToArea procedure: loop once} { + csetup "000\n000\n000" + .b.c find overlapping 0 0 0 0 +} [.b.c find withtag text] +test font-25.2 {Tk_TextLayoutToArea procedure: loop multiple} { + csetup "000\t000\t000" + .b.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 +} [.b.c find withtag text] +test font-25.3 {Tk_TextLayoutToArea procedure: loop to end} { + csetup "0\n000" + .b.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 +} {} +test font-25.4 {Tk_TextLayoutToArea procedure: hit a special char (tab)} { + csetup "000\t000" + .b.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 +} [.b.c find withtag text] +test font-25.5 {Tk_TextLayoutToArea procedure: ignore newlines} { + csetup "000\n0\n000" + .b.c find overlapping $ax $ay $ax $ay +} {} +test font-25.6 {Tk_TextLayoutToArea procedure: ignore spaces at eol} { + csetup "000\n000 000000000" + .b.c itemconfig text -width [expr $ax*10] + set x [.b.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] + .b.c itemconfig text -width 0 + set x +} {} + +test font-26.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { + # If there were a whole bunch of returns or tabs in a row, then the + # temporary buffer could overflow and write on the stack. + + csetup "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" + .b.c itemconfig text -width 800 + .b.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" + .b.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" + .b.c insert text end "end" + set x [.b.c postscript] + set i [string first "(qwerty" $x] + string range $x $i [expr {$i + 213}] +} {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm) +(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm) +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +() +(end) +} + +test font-27.1 {Tk_TextWidth procedure} { + font measure [.b.l cget -font] "000" +} [expr $ax*3] + +test font-28.1 {SetupFontMetrics procedure} { + setup + .b.f config -font $fixed +} {} + +test font-29.1 {TkInitFontAttributes procedure} { + setup + font create xyz + font config xyz +} {-family {} -size 0 -weight normal -slant roman -underline 0 -overstrike 0} + +test font-30.1 {ConfigAttributes procedure: arguments} { + setup + list [catch {font create xyz -family} msg] $msg +} {1 {missing value for "-family" option}} +test font-30.2 {ConfigAttributes procedure: arguments} { + setup + list [catch {font create xyz -xyz xyz} msg] $msg +} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +set i 3 +foreach p { + {family xyz times} + {size 20 40} + {weight normal bold} + {slant roman italic} + {underline 0 1} + {overstrike 0 1} +} { + set opt [lindex $p 0] + test font-30.$i "ConfigAttributes procedure: $opt" { + setup + set x {} + font create xyz -$opt [lindex $p 1] + lappend x [font config xyz -$opt] + font config xyz -$opt [lindex $p 2] + lappend x [font config xyz -$opt] + } [lrange $p 1 2] + incr i +} +foreach p { + {size xyz {1 {expected integer but got "xyz"}}} + {weight xyz {1 {bad -weight value "xyz": must be normal, bold}}} + {slant xyz {1 {bad -slant value "xyz": must be roman, italic}}} + {underline xyz {1 {expected boolean value but got "xyz"}}} + {overstrike xyz {1 {expected boolean value but got "xyz"}}} +} { + test font-30.$i "ConfigAttributes procedure: [lindex $p 0]" { + setup + list [catch {font create xyz -[lindex $p 0] [lindex $p 1]} msg] $msg + } [lindex $p 2] + incr i +} + +test font-31.1 {GetAttributeInfo procedure: error} { + list [catch {font actual xyz -style} msg] $msg +} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +test font-31.2 {GetAttributeInfo procedure: all attributes} { + setup + font create xyz -family xyz + font config xyz +} {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} +set i 3 +foreach p { + {family xyz xyz} + {size 20 20} + {weight normal normal} + {slant italic italic} + {underline yes 1} + {overstrike false 0} +} { + test font-31.$i "GetAttributeInfo procedure: [lindex $p 0]" { + setup + font create xyz -[lindex $p 0] [lindex $p 1] + font config xyz -[lindex $p 0] + } [lindex $p 2] + incr i +} + +# In tests below, one field is set to "xyz" so that font name doesn't +# look like a native X font, so that ParseFontName or TkParseXLFD will +# be called. + +setup + +test font-32.1 {ParseFontName procedure: begins with -} { + lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 +} $times +test font-32.2 {ParseFontName procedure: begins with -*} { + lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 +} $times +test font-32.3 {ParseFontName procedure: begins with -, doesn't look like list} { + lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 +} $times +test font-32.4 {ParseFontName procedure: begins with -, looks like list} { + lindex [font actual {-family times}] 1 +} $times +test font-32.5 {ParseFontName procedure: begins with *} { + lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 +} $times +test font-32.6 {ParseFontName procedure: begins with *} { + font actual *-times-xyz -family +} $times +test font-32.7 {ParseFontName procedure: arguments} { + list [catch {font actual {}} msg] $msg +} {1 {font "" doesn't exist}} +test font-32.8 {ParseFontName procedure: arguments} { + list [catch {font actual {times 20 xyz xyz}} msg] $msg +} {1 {unknown font style "xyz"}} +test font-32.9 {ParseFontName procedure: arguments} { + list [catch {font actual {times xyz xyz}} msg] $msg +} {1 {expected integer but got "xyz"}} +test font-32.10 {ParseFontName 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-32.11 {ParseFontName 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-32.12 {ParseFontName procedure: stylelist error} { + list [catch {font actual {times 12 bold xyz}} msg] $msg +} {1 {unknown font style "xyz"}} + +test font-33.1 {TkParseXLFD procedure: initial dash} { + font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family +} $times +test font-33.2 {TkParseXLFD procedure: no initial dash} { + font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family +} $times +test font-33.3 {TkParseXLFD procedure: not enough fields} { + font actual -xyz-times-*-*-* -family +} $times +test font-33.4 {TkParseXLFD procedure: all fields unspecified} { + lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 +} {-family} +test font-33.5 {TkParseXLFD procedure: all fields specified} { + lindex [font actual -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 +} $times +test font-33.6 {TkParseXLFD procedure: arguments} { + # XLFD with bad pointsize: fallback to some system font. + font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-* + set x {} +} {} +test font-33.7 {TkParseXLFD procedure: arguments} { + # XLFD with bad pixelsize: fallback to some system font. + font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* + set x {} +} {} +test font-33.8 {TkParseXLFD procedure: pixelsize specified} { + font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace + set x {} +} {} +test font-33.9 {TkParseXLFD procedure: weird pixelsize specified} { + font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace + set x {} +} {} +test font-33.10 {TkParseXLFD procedure: pointsize specified} { + font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace + set x {} +} {} +test font-33.11 {TkParseXLFD procedure: weird pointsize specified} { + font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace + set x {} +} {} + +test font-34.1 {FieldSpecified procedure: specified vs. non-specified} { + font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-* + font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-* + font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-* + lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 +} $times + +test font-35.1 {NewChunk procedure: test realloc} { + .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" +} {} + +destroy .b +return diff --git a/tests/frame.test b/tests/frame.test new file mode 100644 index 0000000..c23d851 --- /dev/null +++ b/tests/frame.test @@ -0,0 +1,617 @@ +# This file is a Tcl script to test out the "frame" and "toplevel" +# commands of Tk. It is organized in the standard fashion for Tcl +# tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) frame.test 1.29 97/10/10 15:52:19 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + catch {destroy $i} +} +wm geometry . {} +raise . + +# eatColors -- +# Creates a toplevel window and allocates enough colors in it to +# use up all the slots in the colormap. +# +# Arguments: +# w - Name of toplevel window to create. + +proc eatColors {w} { + catch {destroy $w} + toplevel $w + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] + $w.c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } + } + update +} + +# colorsFree -- +# +# Returns 1 if there appear to be free colormap entries in a window, +# 0 otherwise. +# +# Arguments: +# w - Name of window in which to check. +# red, green, blue - Intensities to use in a trial color allocation +# to see if there are colormap entries free. + +proc colorsFree {w {red 31} {green 245} {blue 192}} { + set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] + expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ + && ([lindex $vals 2]/256 == $blue) +} + +test frame-1.1 {frame configuration options} { + frame .f -class NewFrame + list [.f configure -class] [catch {.f configure -class Different} msg] $msg +} {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}} +catch {destroy .f} +test frame-1.2 {frame configuration options} { + list [catch {frame .f -colormap new} msg] $msg +} {0 .f} +catch {destroy .f} +test frame-1.3 {frame configuration options} { + list [catch {frame .f -visual default} msg] $msg +} {0 .f} +catch {destroy .f} +test frame-1.4 {frame configuration options} { + list [catch {frame .f -screen bogus} msg] $msg +} {1 {unknown option "-screen"}} +test frame-1.5 {frame configuration options} { + set result [list [catch {frame .f -container true} msg] $msg \ + [.f configure -container]] + destroy .f + set result +} {0 .f {-container container Container 0 1}} +test frame-1.6 {frame configuration options} { + list [catch {frame .f -container bogus} msg] $msg +} {1 {expected boolean value but got "bogus"}} +test frame-1.7 {frame configuration options} { + frame .f + set result [list [catch {.f configure -container 1} msg] $msg] + destroy .f + set result +} {1 {can't modify -container option after widget is created}} +frame .f +set i 8 +foreach test { + {-background #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-bd 4 4 badValue {bad screen distance "badValue"}} + {-bg #00ff00 #00ff00 non-existent + {unknown color name "non-existent"}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-height 100 100 not_a_number {bad screen distance "not_a_number"}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} + {-highlightcolor #123456 #123456 non-existent + {unknown color name "non-existent"}} + {-highlightthickness 6 6 badValue {bad screen distance "badValue"}} + {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-takefocus "any string" "any string" {} {}} + {-width 32 32 badValue {bad screen distance "badValue"}} +} { + set name [lindex $test 0] + test frame-1.$i {frame configuration options} { + .f configure $name [lindex $test 1] + lindex [.f configure $name] 4 + } [lindex $test 2] + 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]] + } + .f configure $name [lindex [.f configure $name] 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 + wm geometry .t +0+0 + list [.t configure -class] [catch {.t configure -class Another} msg] $msg +} {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}} +test frame-2.2 {toplevel configuration options} { + catch {destroy .t} + toplevel .t -width 200 -height 100 -colormap new + wm geometry .t +0+0 + list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg +} {{-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 + 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}} +test frame-2.4 {toplevel configuration options} { + catch {destroy .t} + list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg +} {1 {bad window path name "bogus"}} +set default "[winfo visual .] [winfo depth .]" +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 + wm geometry .t +0+0 + list [.t configure -visual] [catch {.t configure -visual best} msg] $msg +} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}} +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.9 {toplevel configuration options} { + catch {destroy .t} + list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg +} {1 {couldn't connect to display "bogus"}} +catch {destroy .t} +toplevel .t -width 300 -height 150 +wm geometry .t +0+0 +update +set i 8 +foreach test { + {-background #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-bd 4 4 badValue {bad screen distance "badValue"}} + {-bg #00ff00 #00ff00 non-existent + {unknown color name "non-existent"}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-height 100 100 not_a_number {bad screen distance "not_a_number"}} + {-highlightcolor #123456 #123456 non-existent + {unknown color name "non-existent"}} + {-highlightthickness 3 3 badValue {bad screen distance "badValue"}} + {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-width 32 32 badValue {bad screen distance "badValue"}} +} { + set name [lindex $test 0] + test frame-2.$i {frame configuration options} { + .t configure $name [lindex $test 1] + lindex [.t configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test frame-2.$i {frame configuration options} { + list [catch {.t configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .t configure $name [lindex [.t configure $name] 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} { + catch {destroy .f} + frame .f + set result [.f configure -class] + destroy .f + set result +} {-class class Class Frame Frame} +test frame-3.3 {TkCreateFrame procedure} { + catch {destroy .t} + toplevel .t + wm geometry .t +0+0 + set result [.t configure -class] + destroy .t + set 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 + wm geometry .t +0+0 + update + list [lindex [.t configure -width] 4] \ + [lindex [.t configure -background] 4] \ + [lindex [.t configure -height] 4] +} {350 black 90} + +# Be sure that the -class, -colormap, and -visual options are processed +# before configuring the widget. + +test frame-3.5 {TkCreateFrame procedure} { + catch {destroy .f} + option add *NewFrame.background #123456 + frame .f -class NewFrame + option clear + lindex [.f configure -background] 4 +} {#123456} +test frame-3.6 {TkCreateFrame procedure} { + catch {destroy .f} + option add *NewFrame.background #123456 + frame .f -class NewFrame + option clear + lindex [.f configure -background] 4 +} {#123456} +test frame-3.7 {TkCreateFrame procedure} { + catch {destroy .f} + option add *NewFrame.background #332211 + option add *f.class NewFrame + frame .f + option clear + list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] +} {NewFrame #332211} +test frame-3.8 {TkCreateFrame procedure} { + catch {destroy .f} + option add *Silly.background #122334 + option add *f.Class Silly + frame .f + option clear + list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] +} {Silly #122334} +test frame-3.9 {TkCreateFrame procedure, -use option} unixOnly { + 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 + 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 + set result +} {0 0 140 300} +test frame-3.10 {TkCreateFrame procedure, -use option} unixOnly { + catch {destroy .t} + catch {destroy .x} + 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 + option clear + set result +} {0 0 140 300} + +# The tests below require specific display characteristics. Even so, +# they are non-portable: some machines don't seem to ever run out of +# colors. + +if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} { + 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} + } + destroy .t1 +} +test frame-3.22 {TkCreateFrame procedure, default dimensions} { + catch {destroy .t} + toplevel .t + wm geometry .t +0+0 + update + set result "[winfo reqwidth .t] [winfo reqheight .t]" + frame .t.f -bg red + pack .t.f + update + lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f] + destroy .t + set result +} {200 200 1 1} +test frame-3.23 {TkCreateFrame procedure} { + catch {destroy .f} + list [catch {frame .f -gorp glob} msg] $msg +} {1 {unknown option "-gorp"}} +test frame-3.24 {TkCreateFrame procedure} { + 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"}} + +test frame-4.1 {TkCreateFrame procedure} { + catch {destroy .f} + catch {frame .f -gorp glob} + winfo exists .f +} 0 +test frame-4.2 {TkCreateFrame procedure} { + catch {destroy .f} + list [frame .f -width 200 -height 100] [winfo exists .f] +} {.f 1} + +catch {destroy .f} +frame .f -highlightcolor black +test frame-5.1 {FrameWidgetCommand procedure} { + list [catch .f msg] $msg +} {1 {wrong # args: should be ".f option ?arg arg ...?"}} +test scale-5.2 {FrameWidgetCommand procedure, cget option} { + list [catch {.f cget} msg] $msg +} {1 {wrong # args: should be ".f cget option"}} +test scale-5.3 {FrameWidgetCommand procedure, cget option} { + list [catch {.f cget a b} msg] $msg +} {1 {wrong # args: should be ".f cget option"}} +test scale-5.4 {FrameWidgetCommand procedure, cget option} { + list [catch {.f cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test scale-5.5 {FrameWidgetCommand procedure, cget option} { + .f cget -highlightcolor +} {black} +test scale-5.6 {FrameWidgetCommand procedure, cget option} { + list [catch {.f cget -screen} msg] $msg +} {1 {unknown option "-screen"}} +test scale-5.7 {FrameWidgetCommand procedure, cget option} { + catch {destroy .t} + toplevel .t + catch {.t cget -screen} +} {0} +catch {destroy .t} +test frame-5.8 {FrameWidgetCommand procedure, configure option} { + llength [.f configure] +} {16} +test frame-5.9 {FrameWidgetCommand procedure, configure option} { + list [catch {.f configure -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test frame-5.10 {FrameWidgetCommand procedure, configure option} { + list [catch {.f configure -gorp bogus} msg] $msg +} {1 {unknown option "-gorp"}} +test frame-5.11 {FrameWidgetCommand procedure, configure option} { + list [catch {.f configure -width 200 -height} msg] $msg +} {1 {value for "-height" missing}} +test frame-5.12 {FrameWidgetCommand procedure} { + list [catch {.f swizzle} msg] $msg +} {1 {bad option "swizzle": must be cget or configure}} + +test frame-6.1 {ConfigureFrame procedure} { + catch {destroy .f} + frame .f -width 150 + list [winfo reqwidth .f] [winfo reqheight .f] +} {150 1} +test frame-6.2 {ConfigureFrame procedure} { + catch {destroy .f} + frame .f -height 97 + list [winfo reqwidth .f] [winfo reqheight .f] +} {1 97} +test frame-6.3 {ConfigureFrame procedure} { + catch {destroy .f} + frame .f + set result {} + lappend result [winfo reqwidth .f] [winfo reqheight .f] + .f configure -width 100 -height 180 + lappend result [winfo reqwidth .f] [winfo reqheight .f] + .f configure -width 0 -height 0 + lappend result [winfo reqwidth .f] [winfo reqheight .f] +} {1 1 100 180 100 180} + +test frame-7.1 {FrameEventProc procedure} { + frame .frame2 + set result [info commands .frame2] + destroy .frame2 + lappend result [info commands .frame2] +} {.frame2 {}} +test frame-7.2 {FrameEventProc procedure} { + eval destroy [winfo children .] + frame .f1 -bg #543210 + rename .f1 .f2 + set x {} + lappend x [winfo children .] + lappend x [.f2 cget -bg] + destroy .f1 + lappend x [info command .f*] [winfo children .] +} {.f1 #543210 {} {}} + +test frame-8.1 {FrameCmdDeletedProc procedure} { + eval destroy [winfo children .] + frame .f1 + rename .f1 {} + list [info command .f*] [winfo children .] +} {{} {}} +test frame-8.2 {FrameCmdDeletedProc procedure} { + eval destroy [winfo children .] + toplevel .f1 -menu .m + wm geometry .f1 +0+0 + update + rename .f1 {} + update + list [info command .f*] [winfo children .] +} {{} {}} +test frame-8.3 {FrameCmdDeletedProc procedure} { + eval destroy [winfo children .] + toplevel .f1 -menu .m + wm geometry .f1 +0+0 + menu .m + update + rename .f1 {} + update + set result [list [info command .f*] [winfo children .]] + eval destroy [winfo children .] + set result +} {{} .m} + +test frame-9.1 {MapFrame procedure} { + catch {destroy .t} + toplevel .t -width 100 -height 400 + wm geometry .t +0+0 + set result [winfo ismapped .t] + update idletasks + lappend result [winfo ismapped .t] +} {0 1} +test frame-9.2 {MapFrame procedure} { + catch {destroy .t} + toplevel .t -width 100 -height 400 + wm geometry .t +0+0 + destroy .t + update + winfo exists .t +} {0} +test frame-9.3 {MapFrame procedure, window deleted while mapping} { + toplevel .t2 -width 200 -height 200 + wm geometry .t2 +0+0 + tkwait visibility .t2 + catch {destroy .t} + toplevel .t -width 100 -height 400 + wm geometry .t +0+0 + frame .t2.f -width 50 -height 50 + bind .t2.f <Configure> {destroy .t} + pack .t2.f -side top + update idletasks + winfo exists .t +} {0} + +set l [interp hidden] +eval destroy [winfo children .] + +test frame-10.1 {frame widget vs hidden commands} { + catch {destroy .t} + frame .t + interp hide {} .t + destroy .t + list [winfo children .] [interp hidden] +} [list {} $l] + +test frame-11.1 {TkInstallFrameMenu} { + catch {destroy .t} + menu .m1 + .m1 add cascade -menu .m1.system + menu .m1.system -tearoff 0 + .m1.system add command -label foo + list [toplevel .t -menu .m1] [destroy .m1] [destroy .t] +} {.t {} {}} +test frame-11.2 {TkInstallFrameMenu - frame renamed} { + catch {destroy .t} + catch {rename foo {}} + menu .m1 + .m1 add cascade -menu .m1.system + menu .m1.system -tearoff 0 + .m1.system add command -label foo + toplevel .t + list [rename .t foo] [destroy .t] [destroy foo] [destroy .m1] +} {{} {} {} {}} + + +catch {destroy .f} +rename eatColors {} +rename colorsFree {} diff --git a/tests/geometry.test b/tests/geometry.test new file mode 100644 index 0000000..d5d1f01 --- /dev/null +++ b/tests/geometry.test @@ -0,0 +1,251 @@ +# This file is a Tcl script to test the procedures in the file +# tkGeometry.c (generic support for geometry managers). It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) geometry.test 1.9 96/02/16 10:55:06 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . 300x300 +raise . +update + +frame .f -bd 2 -relief raised +frame .f.f -bd 2 -relief sunken +frame .f.f.f -bd 2 -relief raised +button .b1 -text .b1 +button .b2 -text .b2 +button .b3 -text .b3 +button .f.f.b4 -text .b4 + +test geometry-1.1 {Tk_ManageGeometry procedure} { + place .b1 -x 120 -y 80 + update + list [winfo x .b1] [winfo y .b1] +} {120 80} +test geometry-1.2 {Tk_ManageGeometry procedure} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .b1 -in .f -x 40 -y 30 + update + pack .b1 -side top -anchor w + place .f -x 30 -y 40 + update + list [winfo x .b1] [winfo y .b1] +} {0 0} + +test geometry-2.1 {Tk_GeometryRequest procedure} { + frame .f2 + set result [list [winfo reqwidth .f2] [winfo reqheight .f2]] + .f2 configure -width 150 -height 300 + update + lappend result [winfo reqwidth .f2] [winfo reqheight .f2] \ + [winfo geom .f2] + place .f2 -x 10 -y 20 + update + lappend result [winfo geom .f2] + .f2 configure -width 100 -height 80 + update + lappend result [winfo geom .f2] +} {1 1 150 300 1x1+0+0 150x300+10+20 100x80+10+20} +catch {destroy .f2} + +test geometry-3.1 {Tk_SetInternalBorder procedure} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .b1 -in .f -x 50 -y 5 + update + set x [list [winfo x .b1] [winfo y .b1]] + .f configure -bd 5 + update + lappend x [winfo x .b1] [winfo y .b1] +} {72 37 75 40} +.f configure -bd 2 + +test geometry-4.1 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .f.f -x 15 -y 5 -width 150 -height 120 + place .f.f.f -width 100 -height 80 + place .b1 -in .f.f.f -x 50 -y 5 + update + list [winfo x .b1] [winfo y .b1] +} {91 46} +test geometry-4.2 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .f.f -x 15 -y 5 -width 150 -height 120 + place .f.f.f -width 100 -height 80 + place .b1 -in .f.f.f -x 50 -y 5 + place .b2 -in .f.f.f -x 10 -y 25 + place .b3 -in .f.f.f -x 50 -y 25 + update + place .f -x 30 -y 25 + update + list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ + [winfo x .b3] [winfo y .b3] +} {101 41 61 61 101 61} +test geometry-4.3 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .f.f -x 15 -y 5 -width 150 -height 120 + place .f.f.f -width 100 -height 80 + place .b1 -in .f.f.f -x 50 -y 5 + place .b2 -in .f.f.f -x 10 -y 25 + place .b3 -in .f.f.f -x 50 -y 25 + update + destroy .b1 + button .b1 -text .b1 + place .f.f -x 10 -y 25 + update + list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ + [winfo x .b3] [winfo y .b3] +} {0 0 46 86 86 86} +test geometry-4.4 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .f.f -x 15 -y 5 -width 150 -height 120 + place .f.f.f -width 100 -height 80 + place .b1 -in .f.f.f -x 50 -y 5 + place .b2 -in .f.f.f -x 10 -y 25 + place .b3 -in .f.f.f -x 50 -y 25 + update + destroy .b2 + button .b2 -text .b2 + place .f.f.f -x 2 -y 3 + update + list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ + [winfo x .b3] [winfo y .b3] +} {93 49 0 0 93 69} +test geometry-4.5 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .f.f -x 15 -y 5 -width 150 -height 120 + place .f.f.f -width 100 -height 80 + place .b1 -in .f.f.f -x 50 -y 5 + place .b2 -in .f.f.f -x 10 -y 25 + place .b3 -in .f.f.f -x 50 -y 25 + update + destroy .b3 + button .b3 -text .b3 + place .f.f.f -x 2 -y 3 + update + list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ + [winfo x .b3] [winfo y .b3] +} {93 49 53 69 0 0} +test geometry-4.6 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3 .f.f.b4} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .f.f -x 15 -y 5 -width 150 -height 120 + place .f.f.f -width 100 -height 80 + place .f.f.b4 -in .f.f.f -x 50 -y 5 + place .b2 -in .f.f.f -x 10 -y 25 + update + place .f -x 25 -y 35 + update + list [winfo x .f.f.b4] [winfo y .f.f.b4] [winfo x .b2] [winfo y .b2] +} {54 9 56 71} +test geometry-4.7 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3 .f.f.b4} { + place forget $w + } + bind .b1 <Configure> {lappend x configure} + place .f -x 20 -y 30 -width 200 -height 200 + place .f.f -x 15 -y 5 -width 150 -height 120 + place .f.f.f -width 100 -height 80 + place .f.f.b4 -in .f.f.f -x 50 -y 5 + place .b1 -in .f.f.f -x 10 -y 25 + update + set x init + place .f -x 25 -y 35 + update + lappend x | + place .f -x 30 -y 40 + place .f.f -x 10 -y 0 + update + bind .b1 <Configure> {} + set x +} {init configure |} +test geometry-4.8 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .f.f -x 15 -y 5 -width 150 -height 120 + place .f.f.f -width 100 -height 80 + place .b1 -in .f.f.f -x 50 -y 5 + place .b2 -in .f.f.f -x 10 -y 25 + place .b3 -in .f.f.f -x 50 -y 25 + update + destroy .f.f + frame .f.f -bd 2 -relief raised + frame .f.f.f -bd 2 -relief raised + place .f -x 30 -y 25 + update + list [winfo x .b1] [winfo y .b1] [winfo ismapped .b1] \ + [winfo x .b2] [winfo y .b2] [winfo ismapped .b2] \ + [winfo x .b3] [winfo y .b3] [winfo ismapped .b3] +} {91 46 0 51 66 0 91 66 0} +test geometry-4.9 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + place .f -x 20 -y 30 -width 200 -height 200 + place .f.f -x 15 -y 5 -width 150 -height 120 + place .f.f.f -width 100 -height 80 + place .b1 -in .f.f.f -x 50 -y 5 + update + set result [winfo ismapped .b1] + place forget .f.f + update + lappend result [winfo ismapped .b1] + place .f.f -x 15 -y 5 -width 150 -height 120 + update + lappend result [winfo ismapped .b1] +} {1 0 1} +test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + toplevel .t + wm geometry .t +0+0 + tkwait visibility .t + update + frame .t.f + pack .t.f + button .t.quit -text Quit -command exit + pack .t.quit -in .t.f + wm iconify .t + set x 0 + after 500 {set x 1} + tkwait variable x + wm deiconify .t + update + winfo ismapped .t.quit +} {1} +catch {destroy .t} +concat diff --git a/tests/grid.test b/tests/grid.test new file mode 100644 index 0000000..fae31fe --- /dev/null +++ b/tests/grid.test @@ -0,0 +1,1205 @@ +# This file is a Tcl script to test out the *NEW* "grid" command +# of Tk. It is (almost) organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) grid.test 1.22 97/10/10 10:07:31 + +if {[string compare test [info procs test]] == 1} then \ + {source ../tests/defs} + +# Test Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "testConfig". If any of these +# elements is zero, the test is skipped. +# This argument may be omitted. +# script - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. +# answer - Expected result from script. + +# helper routine to return "." to a sane state after a test +# The variable GRID_VERBOSE can be used to "look" at the result +# of one or all of the tests + +proc grid_reset {{test ?} {top .}} { + global GRID_VERBOSE + if {[info exists GRID_VERBOSE]} { + if {$GRID_VERBOSE=="" || $GRID_VERBOSE==$test} { + puts -nonewline "grid test $test: " + flush stdout + gets stdin + } + } + eval destroy [winfo children $top] + update + foreach {cols rows} [grid size .] {} + for {set i 0} {$i <= $cols} {incr i} { + grid columnconfigure . $i -weight 0 -minsize 0 -pad 0 + } + for {set i 0} {$i <= $rows} {incr i} { + grid rowconfigure . $i -weight 0 -minsize 0 -pad 0 + } + grid propagate . 1 + update +} + +grid_reset 0.0 +wm geometry . {} + +test grid-1.1 {basic argument checking} { + list [catch grid msg] $msg +} {1 {wrong # args: should be "grid option arg ?arg ...?"}} + +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.}} + +test grid-1.3 {basic argument checking} { + button .b + list [catch {grid .b -row 0 -column} msg] $msg +} {1 {extra option or option with no value}} +grid_reset 1.3 + +test grid-1.4 {basic argument checking} { + button .b + list [catch {grid configure .b - foo} msg] $msg +} {1 {unexpected parameter, "foo", in configure list. Should be window name or option}} +grid_reset 1.4 + +test grid-1.5 {basic argument checking} { + list [catch {grid .} msg] $msg +} {1 {can't manage ".": it's a top-level window}} + +test grid-1.6 {basic argument checking} { + list [catch {grid x} msg] $msg +} {1 {can't determine master window}} + +test grid-2.1 {bbox} { + list [catch {grid bbox .} msg] $msg +} {0 {0 0 0 0}} + +test grid-2.2 {bbox} { + button .b + grid .b + destroy .b + update + list [catch {grid bbox .} msg] $msg +} {0 {0 0 0 0}} + +test grid-2.3 {bbox: argument checking} { + list [catch {grid bbox . 0 0 5} msg] $msg +} {1 {wrong number of arguments: must be "grid bbox master ?column row ?column row??"}} + +test grid-2.4 {bbox} { + list [catch {grid bbox .bad 0 0} msg] $msg +} {1 {bad window path name ".bad"}} + +test grid-2.5 {bbox} { + list [catch {grid bbox . x 0} msg] $msg +} {1 {expected integer but got "x"}} + +test grid-2.6 {bbox} { + list [catch {grid bbox . 0 x} msg] $msg +} {1 {expected integer but got "x"}} + +test grid-2.7 {bbox} { + list [catch {grid bbox . 0 0 x 0} msg] $msg +} {1 {expected integer but got "x"}} + +test grid-2.8 {bbox} { + list [catch {grid bbox . 0 0 0 x} msg] $msg +} {1 {expected integer but got "x"}} + +test grid-2.9 {bbox} { + frame .1 -width 75 -height 75 -bg red + frame .2 -width 90 -height 90 -bg red + grid .1 -row 0 -column 0 + grid .2 -row 1 -column 1 + update + set a "" + lappend a [grid bbox .] + lappend a [grid bbox . 0 0] + lappend a [grid bbox . 0 0 1 1] + lappend a [grid bbox . 1 1] + set a +} {{0 0 165 165} {0 0 75 75} {0 0 165 165} {75 75 90 90}} +grid_reset 2.9 + +test grid-2.10 {bbox} { + frame .1 -width 75 -height 75 -bg red + frame .2 -width 90 -height 90 -bg red + grid .1 -row 0 -column 0 + grid .2 -row 1 -column 1 + update + set a "" + lappend a [grid bbox . 10 10 0 0] + lappend a [grid bbox . -2 -2 -1 -1] + lappend a [grid bbox . 10 10 12 12] + set a +} {{0 0 165 165} {0 0 0 0} {165 165 0 0}} +grid_reset 2.10 + +test grid-3.1 {configure: basic argument checking} { + list [catch {grid configure foo} msg] $msg +} {1 {bad argument "foo": must be name of window}} + +test grid-3.2 {configure: basic argument checking} { + button .b + grid configure .b + grid slaves . +} {.b} +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}} +grid_reset 3.3 + +test grid-3.4 {configure: basic argument checking} { + button .b + list [catch {grid .b -column -1} msg] $msg +} {1 {bad column value "-1": must be a non-negative integer}} +grid_reset 3.4 + +test grid-3.5 {configure: basic argument checking} { + button .b + list [catch {grid .b -rowspan 0} msg] $msg +} {1 {bad rowspan value "0": must be a positive integer}} +grid_reset 3.5 + +test grid-3.6 {configure: basic argument checking} { + button .b + list [catch {grid .b -columnspan 0} msg] $msg +} {1 {bad columnspan value "0": must be a positive integer}} +grid_reset 3.6 + +test grid-3.7 {configure: basic argument checking} { + frame .f + button .f.b + list [catch {grid .f .f.b} msg] $msg +} {1 {can't put .f.b inside .}} +grid_reset 3.7 + +test grid-4.1 {forget: basic argument checking} { + list [catch {grid forget foo} msg] $msg +} {1 {bad window path name "foo"}} + +test grid-4.2 {forget} { + button .c + grid [button .b] + set a [grid slaves .] + grid forget .b .c + lappend a [grid slaves .] + set a +} {.b {}} +grid_reset 4.2 + +test grid-4.3 {forget} { + button .c + grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns + grid forget .c + grid .c -row 0 -column 0 + grid info .c +} {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} +grid_reset 4.3 + +test grid-4.4 {forget, 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 forget .f2 + place .f -x 30 + update + lappend x [winfo ismapped .f2] +} {1 0} +grid_reset 4.4 + +test grid-5.1 {info: basic argument checking} { + list [catch {grid info a b} msg] $msg +} {1 {wrong # args: should be "grid info window"}} + +test grid-5.2 {info} { + frame .1 -width 75 -height 75 -bg red + grid .1 -row 0 -column 0 + update + list [catch {grid info .x} msg] $msg +} {1 {bad window path name ".x"}} +grid_reset 5.2 + +test grid-5.3 {info} { + frame .1 -width 75 -height 75 -bg red + grid .1 -row 0 -column 0 + update + list [catch {grid info .1} msg] $msg +} {0 {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}}} +grid_reset 5.3 + +test grid-5.4 {info} { + frame .1 -width 75 -height 75 -bg red + update + list [catch {grid info .1} msg] $msg +} {0 {}} +grid_reset 5.4 + +test grid-6.1 {location: basic argument checking} { + list [catch "grid location ." msg] $msg +} {1 {wrong # args: should be "grid location master x y"}} + +test grid-6.2 {location: basic argument checking} { + list [catch "grid location .bad 0 0" msg] $msg +} {1 {bad window path name ".bad"}} + +test grid-6.3 {location: basic argument checking} { + list [catch "grid location . x y" msg] $msg +} {1 {bad screen distance "x"}} + +test grid-6.4 {location: basic argument checking} { + list [catch "grid location . 1c y" msg] $msg +} {1 {bad screen distance "y"}} + +test grid-6.5 {location: basic argument checking} { + frame .f + grid location .f 10 10 +} {-1 -1} +grid_reset 6.5 + +test grid-6.6 {location (x)} { + frame .f -width 200 -height 100 -highlightthickness 0 -bg red + grid .f + update + set got "" + set result "" + for {set x -10} { $x < 220} { incr x} { + set a [grid location . $x 0] + if {$a != $got} { + lappend result $x->$a + set got $a + } + } + set result +} {{-10->-1 0} {0->0 0} {201->1 0}} +grid_reset 6.6 + +test grid-6.7 {location (y)} { + frame .f -width 200 -height 100 -highlightthickness 0 -bg red + grid .f + update + set got "" + set result "" + for {set y -10} { $y < 110} { incr y} { + set a [grid location . 0 $y] + if {$a != $got} { + lappend result $y->$a + set got $a + } + } + set result +} {{-10->0 -1} {0->0 0} {101->0 1}} +grid_reset 6.7 + +test grid-6.8 {location (weights)} { + frame .f -width 200 -height 100 -highlightthickness 0 -bg red + frame .a + grid .a + grid .f -in .a + grid rowconfigure .f 0 -weight 1 + grid columnconfigure .f 0 -weight 1 + grid propagate .a 0 + .a configure -width 110 -height 15 + update + set got "" + set result "" + for {set y -10} { $y < 120} { incr y} { + set a [grid location . $y $y] + if {$a != $got} { + lappend result $y->$a + set got $a + } + } + set result +} {{-10->-1 -1} {0->0 0} {16->0 1} {111->1 1}} +grid_reset 6.8 + +test grid-6.9 {location: check updates pending} { + set a "" + foreach i {0 1 2} { + frame .$i -width 120 -height 75 -bg red + lappend a [grid location . 150 90] + grid .$i -row $i -column $i + } + set a +} {{0 0} {1 1} {1 1}} +grid_reset 6.9 + +test grid-7.1 {propagate} { + list [catch {grid propagate . 1 xxx} msg] $msg +} {1 {wrong # args: should be "grid propagate window ?boolean?"}} +grid_reset 7.1 + +test grid-7.2 {propagate} { + list [catch {grid propagate .} msg] $msg +} {0 1} +grid_reset 7.2 + +test grid-7.3 {propagate} { + list [catch {grid propagate . 0;grid propagate .} msg] $msg +} {0 0} +grid_reset 7.3 + +test grid-7.4 {propagate} { + list [catch {grid propagate .x} msg] $msg +} {1 {bad window path name ".x"}} +grid_reset 7.4 + +test grid-7.5 {propagate} { + list [catch {grid propagate . x} msg] $msg +} {1 {expected boolean value but got "x"}} +grid_reset 7.5 + +test grid-7.6 {propagate} { + frame .f -width 100 -height 100 -bg red + grid .f -row 0 -column 0 + update + set a [winfo width .f]x[winfo height .f] + grid propagate .f 0 + frame .g -width 75 -height 85 -bg green + grid .g -in .f -row 0 -column 0 + update + lappend a [winfo width .f]x[winfo height .f] + grid propagate .f 1 + update + lappend a [winfo width .f]x[winfo height .f] + set a +} {100x100 100x100 75x85} +grid_reset 7.6 + + +test grid-8.1 {size} { + list [catch {grid size . foo} msg] $msg +} {1 {wrong # args: should be "grid size window"}} +grid_reset 8.1 + +test grid-8.2 {size} { + list [catch {grid size .x} msg] $msg +} {1 {bad window path name ".x"}} +grid_reset 8.2 + +test grid-8.3 {size} { + frame .f + list [catch {grid size .f} msg] $msg +} {0 {0 0}} +grid_reset 8.3 + +test grid-8.4 {size} { + catch {unset a} + scale .f + grid .f -row 0 -column 0 + update + lappend a [grid size .] + grid .f -row 4 -column 5 + update + lappend a [grid size .] + grid .f -row 947 -column 663 + update + lappend a [grid size .] + grid .f -row 0 -column 0 + update + lappend a [grid size .] + set a +} {{1 1} {6 5} {664 948} {1 1}} +grid_reset 8.4 + +test grid-8.5 {size} { + catch {unset a} + scale .f + grid .f -row 0 -column 0 + update + lappend a [grid size .] + grid rowconfigure . 17 -weight 1 + update + lappend a [grid size .] + grid columnconfigure . 63 -weight 1 + update + lappend a [grid size .] + grid columnconfigure . 63 -weight 0 + grid rowconfigure . 17 -weight 0 + update + lappend a [grid size .] + set a +} {{1 1} {1 18} {64 18} {1 1}} +grid_reset 8.5 + +test grid-8.6 {size} { + catch {unset a} + scale .f + grid .f -row 10 -column 50 + update + lappend a [grid size .] + grid columnconfigure . 15 -weight 1 + grid columnconfigure . 30 -weight 1 + update + lappend a [grid size .] + grid .f -row 10 -column 20 + update + lappend a [grid size .] + grid columnconfigure . 30 -weight 0 + update + lappend a [grid size .] + grid .f -row 0 -column 0 + update + lappend a [grid size .] + grid columnconfigure . 15 -weight 0 + update + lappend a [grid size .] + set a +} {{51 11} {51 11} {31 11} {21 11} {16 1} {1 1}} +grid_reset 8.6 + +test grid-9.1 {slaves} { + list [catch {grid slaves .} msg] $msg +} {0 {}} + +test grid-9.2 {slaves} { + list [catch {grid slaves .foo} msg] $msg +} {1 {bad window path name ".foo"}} + +test grid-9.3 {slaves} { + list [catch {grid slaves a b} msg] $msg +} {1 {wrong # args: should be "grid slaves window ?-option value...?"}} + +test grid-9.4 {slaves} { + list [catch {grid slaves . a b} msg] $msg +} {1 {invalid args: should be "grid slaves window ?-option value...?"}} + +test grid-9.5 {slaves} { + list [catch {grid slaves . -foo x} msg] $msg +} {1 {expected integer but got "x"}} + +test grid-9.6 {slaves} { + list [catch {grid slaves . -foo -3} msg] $msg +} {1 {-foo is an invalid value: should NOT be < 0}} + +test grid-9.7 {slaves} { + list [catch {grid slaves . -foo 3} msg] $msg +} {1 {-foo is an invalid option: should be "-row, -column"}} + +test grid-9.8 {slaves} { + list [catch {grid slaves .x -row 3} msg] $msg +} {1 {bad window path name ".x"}} + +test grid-9.9 {slaves} { + list [catch {grid slaves . -row 3} msg] $msg +} {0 {}} + +test grid-9.10 {slaves} { + foreach i {0 1 2} { + label .$i -text $i + grid .$i -row $i -column $i + } + list [catch {grid slaves .} msg] $msg +} {0 {.2 .1 .0}} +grid_reset 9.10 + +test grid-9.11 {slaves} { + catch {unset a} + foreach i {0 1 2} { + label .$i -text $i + label .$i-x -text $i-x + grid .$i -row $i -column $i + grid .$i-x -row $i -column [incr i] + } + foreach row {0 1 2 3} { + lappend a $row{[grid slaves . -row $row]} + } + foreach col {0 1 2 3} { + lappend a $col{[grid slaves . -column $col]} + } + set a +} {{0{.0-x .0}} {1{.1-x .1}} {2{.2-x .2}} 3{} 0{.0} {1{.1 .0-x}} {2{.2 .1-x}} 3{.2-x}} +grid_reset 9.11 + +# column/row configure + +test grid-10.1 {column/row configure} { + list [catch {grid columnconfigure .} msg] $msg +} {1 {wrong # args: should be "grid columnconfigure master index ?-option value...?"}} +grid_reset 10.1 + +test grid-10.2 {column/row configure} { + list [catch {grid columnconfigure . 0 -weight 0 -pad} msg] $msg +} {1 {wrong # args: should be "grid columnconfigure master index ?-option value...?"}} +grid_reset 10.2 + +test grid-10.3 {column/row configure} { + list [catch {grid columnconfigure .f 0 -weight} msg] $msg +} {1 {bad window path name ".f"}} +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"}} +grid_reset 10.4 + +test grid-10.5 {column/row configure} { + list [catch {grid columnconfigure . 265 -weight} msg] $msg +} {0 0} +grid_reset 10.5 + +test grid-10.6 {column/row configure} { + list [catch {grid columnconfigure . 0} msg] $msg +} {0 {-minsize 0 -pad 0 -weight 0}} +grid_reset 10.6 + +test grid-10.7 {column/row configure} { + list [catch {grid columnconfigure . 0 -foo} msg] $msg +} {1 {invalid arg "-foo": expecting -minsize, -pad, or -weight.}} +grid_reset 10.7 + +test grid-10.8 {column/row configure} { + list [catch {grid columnconfigure . 0 -minsize foo} msg] $msg +} {1 {bad screen distance "foo"}} +grid_reset 10.8 + +test grid-10.9 {column/row configure} { + list [catch {grid columnconfigure . 0 -minsize foo} msg] $msg +} {1 {bad screen distance "foo"}} +grid_reset 10.9 + +test grid-10.10 {column/row configure} { + grid columnconfigure . 0 -minsize 10 + grid columnconfigure . 0 -minsize +} {10} +grid_reset 10.10 + +test grid-10.11 {column/row configure} { + list [catch {grid columnconfigure . 0 -weight bad} msg] $msg +} {1 {expected integer but got "bad"}} +grid_reset 10.10a + +test grid-10.12 {column/row configure} { + list [catch {grid columnconfigure . 0 -weight -3} msg] $msg +} {1 {invalid arg "-weight": should be non-negative}} +grid_reset 10.11 + +test grid-10.13 {column/row configure} { + grid columnconfigure . 0 -weight 3 + grid columnconfigure . 0 -weight +} {3} +grid_reset 10.12 + +test grid-10.14 {column/row configure} { + list [catch {grid columnconfigure . 0 -pad foo} msg] $msg +} {1 {bad screen distance "foo"}} +grid_reset 10.13 + +test grid-10.15 {column/row configure} { + list [catch {grid columnconfigure . 0 -pad -3} msg] $msg +} {1 {invalid arg "-pad": should be non-negative}} +grid_reset 10.14 + +test grid-10.16 {column/row configure} { + grid columnconfigure . 0 -pad 3 + grid columnconfigure . 0 -pad +} {3} +grid_reset 10.15 + +test grid-10.17 {column/row configure} { + frame .f + set a "" + grid columnconfigure .f 0 -weight 0 + lappend a [grid columnconfigure .f 0 -weight] + grid columnconfigure .f 0 -weight 1 + lappend a [grid columnconfigure .f 0 -weight] + grid rowconfigure .f 0 -weight 0 + lappend a [grid rowconfigure .f 0 -weight] + grid rowconfigure .f 0 -weight 1 + lappend a [grid columnconfigure .f 0 -weight] + grid columnconfigure .f 0 -weight 0 + set a +} {0 1 0 1} +grid_reset 10.16 + +test grid-10.18 {column/row configure} { + frame .f + grid columnconfigure .f 0 -minsize 10 -weight 1 + list [grid columnconfigure .f 0 -minsize] \ + [grid columnconfigure .f 1 -minsize] \ + [grid columnconfigure .f 0 -weight] \ + [grid columnconfigure .f 1 -weight] +} {10 0 1 0} +grid_reset 10.17 + +# auto-placement tests + +test grid-11.1 {default widget placement} { + list [catch {grid ^} msg] $msg +} {1 {can't use '^', cant find master}} +grid_reset 11.1 + +test grid-11.2 {default widget placement} { + button .b + list [catch {grid .b ^} msg] $msg +} {1 {can't find slave to extend with "^".}} +grid_reset 11.2 + +test grid-11.3 {default widget placement} { + button .b + list [catch {grid .b - - .c} msg] $msg +} {1 {bad window path name ".c"}} +grid_reset 11.3 + +test grid-11.4 {default widget placement} { + button .b + list [catch {grid .b - - = -} msg] $msg +} {1 {invalid window shortcut, "=" should be '-', 'x', or '^'}} +grid_reset 11.4 + +test grid-11.5 {default widget placement} { + button .b + list [catch {grid .b - x -} msg] $msg +} {1 {Must specify window before shortcut '-'.}} +grid_reset 11.5 + +test grid-11.6 {default widget placement} { + foreach i {1 2 3 4 5 6} { + frame .f$i -width 50 -height 50 -highlightthickness 0 -bg red + } + grid .f1 .f2 .f3 .f4 + grid .f5 - x .f6 -sticky nsew + update + set a "" + foreach i {5 6} { + lappend a "[winfo x .f$i],[winfo y .f$i] \ + [winfo width .f$i],[winfo height .f$i]" + } + set a +} {{0,50 100,50} {150,50 50,50}} +grid_reset 11.6 + +test grid-11.7 {default widget placement} { + frame .f -width 20 -height 20 -highlightthickness 0 -bg red + grid .f -row 5 -column 5 + list [catch "grid .f x -" msg] $msg +} {1 {Must specify window before shortcut '-'.}} +grid_reset 11.7 + +test grid-11.8 {default widget placement} { + frame .f -width 20 -height 20 -highlightthickness 0 -bg red + grid .f -row 5 -column 5 + list [catch "grid .f ^ -" msg] $msg +} {1 {Must specify window before shortcut '-'.}} +grid_reset 11.8 + +test grid-11.9 {default widget placement} { + frame .f -width 20 -height 20 -highlightthickness 0 -bg red + grid .f -row 5 -column 5 + list [catch "grid .f x ^" msg] $msg +} {1 {can't find slave to extend with "^".}} +grid_reset 11.9 + +test grid-11.10 {default widget placement} { + foreach i {1 2 3} { + frame .f$i -width 100 -height 50 -highlightthickness 0 -bg red + } + grid .f1 .f2 -sticky nsew + grid .f3 ^ -sticky nsew + update + set a "" + foreach i {1 2 3} { + lappend a "[winfo x .f$i],[winfo y .f$i] \ + [winfo width .f$i],[winfo height .f$i]" + } + set a +} {{0,0 100,50} {100,0 100,100} {0,50 100,50}} +grid_reset 11.10 + +test grid-11.11 {default widget placement} { + foreach i {1 2 3 4 5 6 7 8 9 10 11 12} { + frame .f$i -width 50 -height 50 -highlightthickness 1 -highlightbackground black + } + grid .f1 .f2 .f3 .f4 -sticky nsew + grid .f5 .f6 - .f7 -sticky nsew + grid .f8 ^ ^ .f9 -sticky nsew + grid .f10 ^ ^ .f11 -sticky nsew + grid .f12 - - - -sticky nsew + update + set a "" + foreach i {5 6 7 8 9 10 11 12 } { + lappend a "[winfo x .f$i],[winfo y .f$i] \ + [winfo width .f$i],[winfo height .f$i]" + } + set a +} {{0,50 50,50} {50,50 100,150} {150,50 50,50} {0,100 50,50} {150,100 50,50} {0,150 50,50} {150,150 50,50} {0,200 200,50}} +grid_reset 11.11 + +test grid-11.12 {default widget placement} { + foreach i {1 2 3 4} { + frame .f$i -width 75 -height 50 -highlightthickness 1 -highlightbackground black + } + grid .f1 .f2 .f3 -sticky nsew + grid .f4 ^ -sticky nsew + update + set a "" + foreach i {1 2 3 4} { + lappend a "[winfo x .f$i],[winfo y .f$i] \ + [winfo width .f$i],[winfo height .f$i]" + } + grid .f4 ^ -column 1 + update + foreach i {1 2 3 4} { + lappend a "[winfo x .f$i],[winfo y .f$i] \ + [winfo width .f$i],[winfo height .f$i]" + } + set a +} {{0,0 75,50} {75,0 75,100} {150,0 75,50} {0,50 75,50} {0,0 75,50} {75,0 75,100} {150,0 75,100} {75,50 75,50}} +grid_reset 11.12 + +test grid-11.13 {default widget placement} { + foreach i {1 2 3 4 5 6 7} { + frame .f$i -width 40 -height 50 -highlightthickness 1 -highlightbackground black + } + grid .f1 .f2 .f3 .f4 .f5 -sticky nsew + grid .f6 - .f7 -sticky nsew -columnspan 2 + update + set a "" + foreach i {6 7} { + lappend a "[winfo x .f$i],[winfo y .f$i] \ + [winfo width .f$i],[winfo height .f$i]" + } + set a +} {{0,50 120,50} {120,50 80,50}} +grid_reset 11.13 + +test grid-11.14 {default widget placement} { + foreach i {1 2 3} { + frame .f$i -width 50 -height 50 -highlightthickness 0 -bg red + } + grid .f1 .f2 + grid ^ .f3 + update + set a "" + foreach i {1 2 3} { + lappend a "[winfo x .f$i],[winfo y .f$i] \ + [winfo width .f$i],[winfo height .f$i]" + } + set a +} {{0,25 50,50} {50,0 50,50} {50,50 50,50}} +grid_reset 11.14 + +test grid-12.1 {-sticky} { + catch {unset data} + frame .f -width 200 -height 100 -highlightthickness 0 -bg red + set a "" + grid .f + grid rowconfigure . 0 -weight 1 + grid columnconfigure . 0 -weight 1 + grid propagate . 0 + . configure -width 250 -height 150 + foreach i { {} n s e w ns ew nw ne se sw nse nsw sew new nsew} { + grid .f -sticky $i + update + array set data [grid info .f] + append a "($data(-sticky)) [winfo x .f] [winfo y .f] [winfo width .f] [winfo height .f]\n" + } + set a +} {() 25 25 200 100 +(n) 25 0 200 100 +(s) 25 50 200 100 +(e) 50 25 200 100 +(w) 0 25 200 100 +(ns) 25 0 200 150 +(ew) 0 25 250 100 +(nw) 0 0 200 100 +(ne) 50 0 200 100 +(es) 50 50 200 100 +(sw) 0 50 200 100 +(nes) 50 0 200 150 +(nsw) 0 0 200 150 +(esw) 0 50 250 100 +(new) 0 0 250 100 +(nesw) 0 0 250 150 +} +grid_reset 12.1 + +test grid-12.2 {-sticky} { + frame .f -bg red + list [catch "grid .f -sticky glue" msg] $msg +} {1 {bad stickyness value "glue": must be a string containing n, e, s, and/or w}} +grid_reset 12.2 + +test grid-12.3 {-sticky} { + frame .f -bg red + grid .f -sticky {n,s,e,w} + array set A [grid info .f] + set A(-sticky) +} {nesw} +grid_reset 12.3 + +test grid-13.1 {-in} { + frame .f -bg red + list [catch "grid .f -in .f" msg] $msg +} {1 {Window can't be managed in itself}} +grid_reset 13.1 + +test grid-13.2 {-in} { + frame .f -bg red + list [catch "grid .f -in .bad" msg] $msg +} {1 {bad window path name ".bad"}} +grid_reset 13.2 + +test grid-13.3 {-in} { + frame .f -bg red + toplevel .top + list [catch "grid .f -in .top" msg] $msg +} {1 {can't put .f inside .top}} +destroy .top +grid_reset 13.3 + +test grid-13.4 {-ipadx} { + frame .f -width 20 -height 20 -highlightthickness 0 -bg red + list [catch "grid .f -ipadx x" msg] $msg +} {1 {bad ipadx value "x": must be positive screen distance}} +grid_reset 13.4 + +test grid-13.5 {-ipadx} { + frame .f -width 200 -height 100 -highlightthickness 0 -bg red + grid .f + update + set a [winfo width .f] + grid .f -ipadx 1 + update + list $a [winfo width .f] +} {200 202} +grid_reset 13.5 + +test grid-13.6 {-ipady} { + frame .f -width 20 -height 20 -highlightthickness 0 -bg red + list [catch "grid .f -ipady x" msg] $msg +} {1 {bad ipady value "x": must be positive screen distance}} +grid_reset 13.6 + +test grid-13.7 {-ipady} { + frame .f -width 200 -height 100 -highlightthickness 0 -bg red + grid .f + update + set a [winfo height .f] + grid .f -ipady 1 + update + list $a [winfo height .f] +} {100 102} +grid_reset 13.7 + +test grid-13.8 {-padx} { + frame .f -width 20 -height 20 -highlightthickness 0 -bg red + list [catch "grid .f -padx x" msg] $msg +} {1 {bad padx value "x": must be positive screen distance}} +grid_reset 13.8 + +test grid-13.9 {-padx} { + frame .f -width 200 -height 100 -highlightthickness 0 -bg red + grid .f + update + set a "[winfo width .f] [winfo width .]" + grid .f -padx 1 + update + list $a "[winfo width .f] [winfo width .]" +} {{200 200} {200 202}} +grid_reset 13.9 + +test grid-13.10 {-pady} { + frame .f -width 20 -height 20 -highlightthickness 0 -bg red + list [catch "grid .f -pady x" msg] $msg +} {1 {bad pady value "x": must be positive screen distance}} +grid_reset 13.10 + +test grid-13.11 {-pady} { + frame .f -width 200 -height 100 -highlightthickness 0 -bg red + grid .f + update + set a "[winfo height .f] [winfo height .]" + grid .f -pady 1 + update + list $a "[winfo height .f] [winfo height .]" +} {{100 100} {100 102}} +grid_reset 13.11 + +test grid-13.12 {-ipad x and y} { + frame .f -width 20 -height 20 -highlightthickness 0 -bg red + grid columnconfigure . 0 -minsize 150 + grid rowconfigure . 0 -minsize 100 + set a "" + foreach x {0 5} { + foreach y {0 5} { + grid .f -ipadx $x -ipady $y + update + append a " $x,$y:" + foreach prop {x y width height} { + append a ,[winfo $prop .f] + } + } + } + set a +} { 0,0:,65,40,20,20 0,5:,65,35,20,30 5,0:,60,40,30,20 5,5:,60,35,30,30} +grid_reset 13.12 + +test grid-13.13 {reparenting} { + frame .1 + frame .2 + button .b + grid .1 .2 + grid .b -in .1 + set a "" + catch {unset info}; array set info [grid info .b] + lappend a [grid slaves .1],[grid slaves .2],$info(-in) + grid .b -in .2 + catch {unset info}; array set info [grid info .b] + lappend a [grid slaves .1],[grid slaves .2],$info(-in) + unset info + set a +} {.b,,.1 ,.b,.2} +grid_reset 13.13 + +test grid-14.1 {structure notify} { + frame .f -width 200 -height 100 -highlightthickness 0 -bg red + frame .g -width 200 -height 100 -highlightthickness 0 -bg red + grid .f + grid .g -in .f + update + set a "" + lappend a "[winfo x .g],[winfo y .g] \ + [winfo width .g],[winfo height .g]" + .f configure -bd 5 -relief raised + update + lappend a "[winfo x .g],[winfo y .g] \ + [winfo width .g],[winfo height .g]" + set a +} {{0,0 200,100} {5,5 200,100}} +grid_reset 14.1 + +test grid-14.2 {structure notify} { + frame .f -width 200 -height 100 + frame .f.g -width 200 -height 100 + grid .f + grid .f.g + update + set a "" + lappend a [grid bbox .],[grid bbox .f] + .f config -bd 20 + update + lappend a [grid bbox .],[grid bbox .f] +} {{0 0 200 100,0 0 200 100} {0 0 240 140,20 20 200 100}} +grid_reset 14.2 + +test grid-14.3 {map notify} { + global A + catch {unset A} + bind . <Configure> {incr A(%W)} + set A(.) 0 + foreach i {0 1 2} { + frame .$i -width 100 -height 75 + set A(.$i) 0 + } + grid .0 .1 .2 + update + bind <Configure> .1 {destroy .0} + .2 configure -bd 10 + update + bind . <Configure> {} + array get A +} {.2 2 .0 1 . 1 .1 1} +grid_reset 14.3 + +test grid-15.1 {lost slave} { + button .b + grid .b + set a [grid slaves .] + pack .b + lappend a [grid slaves .] + grid .b + lappend a [grid slaves .] +} {.b {} .b} +grid_reset 15.1 + +test grid-15.2 {lost slave} { + frame .f + grid .f + button .b + grid .b -in .f + set a [grid slaves .f] + pack .b + lappend a [grid slaves .f] + grid .b -in .f + lappend a [grid slaves .f] +} {.b {} .b} +grid_reset 15.2 + +test grid-16.1 {layout centering} { + 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 + update + grid bbox . +} {37 50 225 150} +grid_reset 16.1 + +test grid-16.2 {layout weights (expanding)} { + 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 rowconfigure . $i -weight [expr $i + 1] + grid columnconfigure . $i -weight [expr $i + 1] + } + grid propagate . 0 + . configure -width 500 -height 300 + set a "" + update + foreach i {0 1 2} { + lappend a [winfo width .$i]-[winfo height .$i] + } + set a +} {120-75 167-100 213-125} +grid_reset 16.2 + +test grid-16.3 {layout weights (shrinking)} { + foreach i {0 1 2} { + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe + grid rowconfigure . $i -weight [expr $i + 1] + grid columnconfigure . $i -weight [expr $i + 1] + } + grid propagate . 0 + . configure -width 200 -height 150 + set a "" + update + foreach i {0 1 2} { + lappend a [winfo width .$i]-[winfo height .$i] + } + set a +} {84-63 66-50 50-37} +grid_reset 16.3 + +test grid-16.4 {layout weights (shrinking with minsize)} { + foreach i {0 1 2} { + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe + grid rowconfigure . $i -weight [expr $i + 1] -minsize 45 + grid columnconfigure . $i -weight [expr $i + 1] -minsize 65 + } + grid propagate . 0 + . configure -width 200 -height 150 + set a "" + update + foreach i {0 1 2} { + lappend a [winfo width .$i]-[winfo height .$i] + } + set a +} {70-60 65-45 65-45} +grid_reset 16.4 + +test grid-16.5 {layout weights (shrinking at minsize)} { + foreach i {0 1 2} { + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe + grid rowconfigure . $i -weight 0 -minsize 70 + grid columnconfigure . $i -weight 0 -minsize 90 + } + grid propagate . 0 + . configure -width 100 -height 75 + set a "" + update + foreach i {0 1 2} { + lappend a [winfo width .$i]-[winfo height .$i] + } + set a +} {100-75 100-75 100-75} +grid_reset 16.5 + + +test grid-16.6 {layout weights (shrinking at minsize)} { + foreach i {0 1 2} { + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe + grid rowconfigure . $i -weight [expr $i + 1] -minsize 52 + grid columnconfigure . $i -weight [expr $i + 1] -minsize 69 + } + grid propagate . 0 + . configure -width 200 -height 150 + set a "" + update + foreach i {0 1 2} { + lappend a [winfo width .$i]-[winfo height .$i] + } + set a +} {69-52 69-52 69-52} +grid_reset 16.6 + +test grid-16.7 {layout weights (shrinking at minsize)} { + foreach i {0 1 2} { + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe + } + grid propagate . 0 + grid columnconfigure . 1 -weight 1 -minsize 0 + grid rowconfigure . 1 -weight 1 -minsize 0 + . configure -width 100 -height 75 + set a "" + update + foreach i {0 1 2} { + lappend a [winfo width .$i]-[winfo height .$i]-[winfo ismapped .$i] + } + set a +} {100-75-1 1-1-0 200-150-1} +grid_reset 16.7 + +test grid-16.8 {layout internal constraints} { + foreach i {0 1 2 3 4} { + frame .$i -bg gray -width 30 -height 25 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe + } + frame .f -bg red -width 250 -height 200 + frame .g -bg green -width 200 -height 180 + lower .f + raise .g .f + grid .f -row 1 -column 1 -rowspan 3 -columnspan 3 -sticky nswe + grid .g -row 1 -column 1 -rowspan 2 -columnspan 2 -sticky nswe + update + set a "" + foreach i {0 1 2 3 4} { + append a "[winfo x .$i] " + } + append a ", " + grid remove .f + update + foreach i {0 1 2 3 4} { + append a "[winfo x .$i] " + } + append a ", " + grid remove .g + grid .f + update + foreach i {0 1 2 3 4} { + append a "[winfo x .$i] " + } + append a ", " + grid remove .f + update + foreach i {0 1 2 3 4} { + 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 } diff --git a/tests/id.test b/tests/id.test new file mode 100644 index 0000000..2589d48 --- /dev/null +++ b/tests/id.test @@ -0,0 +1,96 @@ +# This file is a Tcl script to test out the procedures in the file +# tkId.c, which recycle X resource identifiers. It is organized in +# the standard fashion for Tcl tests. +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) id.test 1.7 97/05/15 09:47:10 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +test id-1.1 {WindowIdCleanup, delaying window release} {unixOnly} { + bind all <Destroy> {lappend x %W} + catch {unset map} + frame .f + set j 0 + foreach i {a b c d e f g h i j k l m n o p q} { + toplevel .f.$i -height 50 -width 100 + wm geometry .f.$i +$j+$j + incr j 10 + update + set map([winfo id .f.$i]) .f.$i + set map([testwrapper .f.$i]) wrapper.f.$i + } + set x {} + destroy .f + + # Destroy events should have occurred for all windows. + set result [list [lsort $x]] + + set x {} + update idletasks + set reused {} + foreach i {a b c d e} { + set w .${i}2 + frame $w -height 20 -width 100 -bd 2 -relief raised + pack $w + if [info exists map([winfo id $w])] { + lappend reused $map([winfo id $w]) + } + set map([winfo id $w]) $w + } + + # No window ids should have been reused: stale Destroy events still + # pending in queue. + lappend result [lsort $reused] + + # Wait a few seconds, then try again; ids should still not have + # been re-used. + + set y 0 + after 2000 {set y 1} + tkwait variable y + foreach i {a b c} { + set w .${i}3 + frame $w -height 20 -width 100 -bd 2 -relief raised + pack $w + if [info exists map([winfo id $w])] { + lappend reused $map([winfo id $w]) + } + set map([winfo id $w])] $w + } + + # Ids should not yet have been reused. + lappend result [lsort $reused] + + + # Wait a few more seconds, to give ids enough time to be recycled. + set y 0 + after 6000 {set y 1} + tkwait variable y + foreach i {a b c d e f} { + set w .${i}4 + frame $w -height 20 -width 100 -bd 2 -relief raised + pack $w + if [info exists map([winfo id $w])] { + lappend reused $map([winfo id $w]) + } + set map([winfo id $w])] $w + } + + # Ids should be reused now, due to time delay. Destroy events should + # have been discarded. + lappend result [lsort $reused] [lsort $x] +} {{.f .f.a .f.b .f.c .f.d .f.e .f.f .f.g .f.h .f.i .f.j .f.k .f.l .f.m .f.n .f.o .f.p .f.q} {} {} {.f.o .f.p .f.q wrapper.f.p wrapper.f.q} {}} +bind all <Destroy> {} diff --git a/tests/image.test b/tests/image.test new file mode 100644 index 0000000..b4e7ad7 --- /dev/null +++ b/tests/image.test @@ -0,0 +1,357 @@ +# This file is a Tcl script to test out the "image" command and the +# other procedures in the file tkImage.c. It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) image.test 1.15 97/07/31 10:17:25 + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +eval image delete [image names] +canvas .c -highlightthickness 2 +pack .c +update +test image-1.1 {Tk_ImageCmd procedure, "create" option} { + list [catch image msg] $msg +} {1 {wrong # args: should be "image option ?args?"}} +test image-1.2 {Tk_ImageCmd procedure, "create" option} { + list [catch {image gorp} msg] $msg +} {1 {bad option "gorp": must be create, delete, height, names, type, types, or width}} +test image-1.3 {Tk_ImageCmd procedure, "create" option} { + list [catch {image create} msg] $msg +} {1 {wrong # args: should be "image create type ?name? ?options?"}} +test image-1.4 {Tk_ImageCmd procedure, "create" option} { + list [catch {image c bad_type} msg] $msg +} {1 {image type "bad_type" doesn't exist}} +test image-1.5 {Tk_ImageCmd procedure, "create" option} { + list [image create test myimage] [image names] +} {myimage myimage} +test image-1.6 {Tk_ImageCmd procedure, "create" option} { + scan [image create test] image%d first + image create test myimage + scan [image create test -variable x] image%d second + expr $second-$first +} {1} +test image-1.7 {Tk_ImageCmd procedure, "create" option} { + image delete myimage + image create test myimage -variable x + .c create image 100 50 -image myimage + .c create image 100 150 -image myimage + update + set x {} + image create test myimage -variable x + update + set x +} {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} +test image-1.8 {Tk_ImageCmd procedure, "create" option} { + .c delete all + image create test myimage -variable x + .c create image 100 50 -image myimage + .c create image 100 150 -image myimage + image delete myimage + update + set x {} + image create test myimage -variable x + update + set x +} {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} +test image-1.9 {Tk_ImageCmd procedure, "create" option} { + .c delete all + eval image delete [image names] + list [catch {image create test -badName foo} msg] $msg [image names] +} {1 {bad option name "-badName"} {}} + +test image-2.1 {Tk_ImageCmd procedure, "delete" option} { + list [catch {image delete} msg] $msg +} {0 {}} +test image-2.2 {Tk_ImageCmd procedure, "delete" option} { + .c delete all + eval image delete [image names] + image create test myimage + image create test img2 + set result {} + lappend result [lsort [image names]] + image d myimage img2 + lappend result [image names] +} {{img2 myimage} {}} +test image-2.3 {Tk_ImageCmd procedure, "delete" option} { + .c delete all + eval image delete [image names] + image create test myimage + image create test img2 + list [catch {image delete myimage gorp img2} msg] $msg [image names] +} {1 {image "gorp" doesn't exist} img2} + +test image-3.1 {Tk_ImageCmd procedure, "height" option} { + list [catch {image height} msg] $msg +} {1 {wrong # args: should be "image height name"}} +test image-3.2 {Tk_ImageCmd procedure, "height" option} { + list [catch {image height a b} msg] $msg +} {1 {wrong # args: should be "image height name"}} +test image-3.3 {Tk_ImageCmd procedure, "height" option} { + list [catch {image height foo} msg] $msg +} {1 {image "foo" doesn't exist}} +test image-3.4 {Tk_ImageCmd procedure, "height" option} { + image create test myimage + set x [image h myimage] + myimage changed 0 0 0 0 60 50 + list $x [image height myimage] +} {15 50} + +test image-4.1 {Tk_ImageCmd procedure, "names" option} { + list [catch {image names x} msg] $msg +} {1 {wrong # args: should be "image names"}} +test image-4.2 {Tk_ImageCmd procedure, "names" option} { + .c delete all + eval image delete [image names] + image create test myimage + image create test img2 + image create test 24613 + lsort [image names] +} {24613 img2 myimage} +test image-4.3 {Tk_ImageCmd procedure, "names" option} { + .c delete all + eval image delete [image names] + lsort [image names] +} {} + +test image-5.1 {Tk_ImageCmd procedure, "type" option} { + list [catch {image type} msg] $msg +} {1 {wrong # args: should be "image type name"}} +test image-5.2 {Tk_ImageCmd procedure, "type" option} { + list [catch {image type a b} msg] $msg +} {1 {wrong # args: should be "image type name"}} +test image-5.3 {Tk_ImageCmd procedure, "type" option} { + list [catch {image type foo} msg] $msg +} {1 {image "foo" doesn't exist}} +test image-5.4 {Tk_ImageCmd procedure, "type" option} { + image create test myimage + image type myimage +} {test} +test image-5.5 {Tk_ImageCmd procedure, "type" option} { + image create test myimage + .c create image 50 50 -image myimage + image delete myimage + image type myimage +} {} + +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} { + lsort [image types] +} {bitmap photo test} + +test image-7.1 {Tk_ImageCmd procedure, "width" option} { + list [catch {image width} msg] $msg +} {1 {wrong # args: should be "image width name"}} +test image-7.2 {Tk_ImageCmd procedure, "width" option} { + list [catch {image width a b} msg] $msg +} {1 {wrong # args: should be "image width name"}} +test image-7.3 {Tk_ImageCmd procedure, "width" option} { + list [catch {image width foo} msg] $msg +} {1 {image "foo" doesn't exist}} +test image-7.4 {Tk_ImageCmd procedure, "width" option} { + image create test myimage + set x [image w myimage] + myimage changed 0 0 0 0 60 50 + list $x [image width myimage] +} {30 60} + +test image-8.1 {Tk_ImageChanged procedure} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 50 -image foo + update + set x {} + foo changed 5 6 7 8 30 15 + update + set x +} {{foo display 5 6 7 8 30 30}} +test image-8.2 {Tk_ImageChanged procedure} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 50 -image foo + .c create image 90 100 -image foo + update + set x {} + foo changed 5 6 7 8 30 15 + update + set x +} {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} + +test image-9.1 {Tk_GetImage procedure} { + list [catch {.c create image 100 10 -image bad_name} msg] $msg +} {1 {image "bad_name" doesn't exist}} +test image-9.2 {Tk_GetImage procedure} { + image create test mytest + catch {destroy .l} + label .l -image mytest + image delete mytest + set result [list [catch {label .l2 -image mytest} msg] $msg] + destroy .l + set result +} {1 {image "mytest" doesn't exist}} + +test image-10.1 {Tk_FreeImage procedure} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 50 -image foo -tags i1 + .c create image 90 100 -image foo -tags i2 + pack forget .c + update + set x {} + .c delete i1 + pack .c + update + list [image names] $x +} {foo {{foo free} {foo display 0 0 30 15 103 121}}} +test image-10.2 {Tk_FreeImage procedure} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 50 -image foo -tags i1 + image delete foo + update + set names [image names] + set x {} + .c delete i1 + pack forget .c + pack .c + update + list $names [image names] $x +} {foo {} {}} + +# Non-portable, apparently due to differences in rounding: + +test image-11.1 {Tk_RedrawImage procedure, redisplay area clipping} \ + {nonPortable} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 60 -image foo -tags i1 -anchor nw + update + .c create rectangle 30 40 55 65 -width 0 -fill black -outline {} + set x {} + update + set x +} {{foo display 0 0 5 5 50 50}} +test image-11.2 {Tk_RedrawImage procedure, redisplay area clipping} \ + {nonPortable} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 60 -image foo -tags i1 -anchor nw + update + .c create rectangle 60 40 100 65 -width 0 -fill black -outline {} + set x {} + update + set x +} {{foo display 10 0 20 5 30 50}} +test image-11.3 {Tk_RedrawImage procedure, redisplay area clipping} \ + {nonPortable} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 60 -image foo -tags i1 -anchor nw + update + .c create rectangle 60 70 100 200 -width 0 -fill black -outline {} + set x {} + update + set x +} {{foo display 10 10 20 5 30 30}} +test image-11.4 {Tk_RedrawImage procedure, redisplay area clipping} \ + {nonPortable} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 60 -image foo -tags i1 -anchor nw + update + .c create rectangle 30 70 55 200 -width 0 -fill black -outline {} + set x {} + update + set x +} {{foo display 0 10 5 5 50 30}} +test image-11.5 {Tk_RedrawImage procedure, redisplay area clipping} \ + {nonPortable} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 60 -image foo -tags i1 -anchor nw + update + .c create rectangle 10 20 120 130 -width 0 -fill black -outline {} + set x {} + update + set x +} {{foo display 0 0 30 15 70 70}} +test image-11.6 {Tk_RedrawImage procedure, redisplay area clipping} \ + {nonPortable} { + .c delete all + eval image delete [image names] + image create test foo -variable x + .c create image 50 60 -image foo -tags i1 -anchor nw + update + .c create rectangle 55 65 75 70 -width 0 -fill black -outline {} + set x {} + update + set x +} {{foo display 5 5 20 5 30 30}} + +test image-12.1 {Tk_SizeOfImage procedure} { + eval image delete [image names] + image create test 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-12.2 {DeleteImage procedure} { + .c delete all + eval image delete [image names] + image create test 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] | + image delete foo + lappend x | [image names] | +} {{foo free} {foo free} {foo delete} | foo | | foo |} + +catch {image delete hidden} +set l [image names] +set h [interp hidden] + +test image-13.1 {image command vs hidden commands} { + catch {image delete hidden} + image create photo hidden + interp hide {} hidden + image delete hidden + list [image names] [interp hidden] +} [list $l $h] + +destroy .c +eval image delete [image names] diff --git a/tests/imgBmap.test b/tests/imgBmap.test new file mode 100644 index 0000000..928f7a4 --- /dev/null +++ b/tests/imgBmap.test @@ -0,0 +1,474 @@ +# This file is a Tcl script to test out images of type "bitmap" (i.e., +# the procedures in the file tkImgBmap.c). It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) imgBmap.test 1.15 97/03/10 14:12:38 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +set data1 {#define foo_width 16 +#define foo_height 16 +#define foo_x_hot 3 +#define foo_y_hot 3 +static unsigned char foo_bits[] = { + 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0xff, 0xff, 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0xff, 0xff}; +} +set data2 { + #define foo2_width 16 + #define foo2_height 16 + static char foo2_bits[] = { + 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0xff}; +} +makeFile $data1 foo.bm +makeFile $data2 foo2.bm + +eval image delete [image names] +canvas .c +pack .c +update +image create bitmap i1 +.c create image 200 100 -image i1 +update +proc bgerror msg { + global errMsg + set errMsg $msg +} +test imageBmap-1.1 {options for bitmap images} { + image create bitmap i1 -background #123456 + lindex [i1 configure -background] 4 +} {#123456} +test imageBmap-1.2 {options for bitmap images} { + set errMsg {} + image create bitmap i1 -background lousy + update + list $errMsg $errorInfo +} {{unknown color name "lousy"} {unknown color name "lousy" + (while configuring image "i1")}} +test imageBmap-1.3 {options for bitmap images} { + image create bitmap i1 -data $data1 + lindex [i1 configure -data] 4 +} $data1 +test imageBmap-1.4 {options for bitmap images} { + list [catch {image create bitmap i1 -data bogus} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-1.5 {options for bitmap images} { + image create bitmap i1 -file foo.bm + lindex [i1 configure -file] 4 +} foo.bm +test imageBmap-1.6 {options for bitmap images} { + list [catch {image create bitmap i1 -file bogus} msg] [string tolower $msg] +} {1 {couldn't read bitmap file "bogus": no such file or directory}} +test imageBmap-1.7 {options for bitmap images} { + image create bitmap i1 -foreground #00ff00 + lindex [i1 configure -foreground] 4 +} {#00ff00} +test imageBmap-1.8 {options for bitmap images} { + set errMsg {} + image create bitmap i1 -foreground bad_color + update + list $errMsg $errorInfo +} {{unknown color name "bad_color"} {unknown color name "bad_color" + (while configuring image "i1")}} +test imageBmap-1.9 {options for bitmap images} { + image create bitmap i1 -data $data1 -maskdata $data2 + lindex [i1 configure -maskdata] 4 +} $data2 +test imageBmap-1.10 {options for bitmap images} { + list [catch {image create bitmap i1 -data $data1 -maskdata bogus} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-1.11 {options for bitmap images} { + image create bitmap i1 -file foo.bm -maskfile foo2.bm + lindex [i1 configure -maskfile] 4 +} foo2.bm +test imageBmap-1.12 {options for bitmap images} { + list [catch {image create bitmap i1 -data $data1 -maskfile bogus} msg] \ + [string tolower $msg] +} {1 {couldn't read bitmap file "bogus": no such file or directory}} +rename bgerror {} + +test imageBmap-2.1 {ImgBmapCreate procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap -gorp dum} msg] $msg [image names] +} {1 {unknown option "-gorp"} {}} +test imageBmap-2.2 {ImgBmapCreate procedure} { + eval image delete [image names] + .c delete all + image create bitmap image1 + list [info commands image1] [image names] \ + [image width image1] [image height image1] \ + [lindex [image1 configure -foreground] 4] \ + [lindex [image1 configure -background] 4] +} {image1 image1 0 0 #000000 {}} + +test imageBmap-3.1 {ImgBmapConfigureMaster procedure, memory de-allocation} { + image create bitmap i1 -data $data1 + i1 configure -data $data1 +} {} +test imageBmap-3.2 {ImgBmapConfigureMaster procedure} { + image create bitmap i1 -data $data1 + list [catch {i1 configure -data bogus} msg] $msg [image width i1] \ + [image height i1] +} {1 {format error in bitmap data} 16 16} +test imageBmap-3.3 {ImgBmapConfigureMaster procedure, memory de-allocation} { + image create bitmap i1 -data $data1 -maskdata $data2 + i1 configure -maskdata $data2 +} {} +test imageBmap-3.4 {ImgBmapConfigureMaster procedure} { + image create bitmap i1 + list [catch {i1 configure -maskdata $data2} msg] $msg +} {1 {can't have mask without bitmap}} +test imageBmap-3.5 {ImgBmapConfigureMaster procedure} { + list [catch {image create bitmap i1 -data $data1 -maskdata { + #define foo_width 8 + #define foo_height 16 + static char foo_bits[] = { + 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0xff, 0xff, 0xff, 0xff, 0x81, 0x81}; + } + } msg] $msg +} {1 {bitmap and mask have different sizes}} +test imageBmap-3.6 {ImgBmapConfigureMaster procedure} { + list [catch {image create bitmap i1 -data $data1 -maskdata { + #define foo_width 16 + #define foo_height 8 + static char foo_bits[] = { + 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0xff, 0xff, 0xff, 0xff, 0x81, 0x81}; + } + } msg] $msg +} {1 {bitmap and mask have different sizes}} +test imageBmap-3.7 {ImgBmapConfigureMaster procedure} { + image create bitmap i1 -data $data1 + .c create image 100 100 -image i1 -tags i1.1 -anchor nw + .c create image 200 100 -image i1 -tags i1.2 -anchor nw + update + i1 configure -data { + #define foo2_height 14 + #define foo2_width 15 + static char foo2_bits[] = { + 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0xff}; + } + update + list [image width i1] [image height i1] [.c bbox i1.1] [.c bbox i1.2] +} {15 14 {100 100 115 114} {200 100 215 114}} + +test imageBmap-4.1 {ImgBmapConfigureInstance procedure: check error handling} { + proc bgerror args {} + .c delete all + image create bitmap i1 -file foo.bm + .c create image 100 100 -image i1 + update + i1 configure -foreground bogus + update +} {} + +test imageBmap-5.1 {GetBitmapData procedure} { + list [catch {image create bitmap -file ~bad_user/a/b} msg] \ + [string tolower $msg] +} {1 {user "bad_user" doesn't exist}} +test imageBmap-5.2 {GetBitmapData procedure} { + list [catch {image create bitmap -file bad_name} msg] [string tolower $msg] +} {1 {couldn't read bitmap file "bad_name": no such file or directory}} +test imageBmap-5.3 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap -data { }} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.4 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap -data {#define foo2_width}} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.5 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap -data {#define foo2_width gorp}} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.6 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap -data {#define foo2_width 1.4}} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.7 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap -data {#define foo2_height}} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.8 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap -data {#define foo2_height gorp}} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.9 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap -data {#define foo2_height 1.4}} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.10 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + image create bitmap i1 -data { + #define foo2_height 14 + #define foo2_width 15 xx _widtg 18 xwidth 18 _heighz 18 xheight 18 + static char foo2_bits[] = { + 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0xff}; + } + list [image width i1] [image height i1] +} {15 14} +test imageBmap-5.11 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + image create bitmap i1 -data { + _height 14 _width 15 + char { + 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0xff} + } + list [image width i1] [image height i1] +} {15 14} +test imageBmap-5.12 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap i1 -data { + #define foo2_height 14 + #define foo2_width 15 + static short foo2_bits[] = { + 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0xff}; + }} msg] $msg +} {1 {format error in bitmap data; looks like it's an obsolete X10 bitmap file}} +test imageBmap-5.13 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap i1 -data { + #define foo2_height 16 + #define foo2_width 16 + static char foo2_bits[] = + 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0xff; + }} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.14 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap i1 -data { + #define foo2_width 16 + static char foo2_bits[] = { + 0xff, 0xff, 0xff, }}} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.15 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap i1 -data { + #define foo2_height 16 + static char foo2_bits[] = { + 0xff, 0xff, 0xff, }}} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.16 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap i1 -data { + #define foo2_height 16 + #define foo2_width 16 + static char foo2_bits[] = { + 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, foo}; + }} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-5.17 {GetBitmapData procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap i1 -data " + #define foo2_height 16 + #define foo2_width 16 + static char foo2_bits[] = \{ + 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, + 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, + 0xff + "} msg] $msg +} {1 {format error in bitmap data}} + +test imageBmap-6.1 {NextBitmapWord procedure} { + eval image delete [image names] + .c delete all + list [catch {image create bitmap i1 -data {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890}} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-6.2 {NextBitmapWord procedure} { + eval image delete [image names] + .c delete all + makeFile {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890} foo3.bm + list [catch {image create bitmap i1 -file foo3.bm} msg] $msg +} {1 {format error in bitmap data}} +test imageBmap-6.3 {NextBitmapWord procedure} { + eval image delete [image names] + .c delete all + makeFile { } foo3.bm + list [catch {image create bitmap i1 -file foo3.bm} msg] $msg +} {1 {format error in bitmap data}} +removeFile foo3.bm + +eval image delete [image names] +.c delete all +image create bitmap i1 +test imageBmap-7.1 {ImgBmapCmd procedure} { + list [catch {i1} msg] $msg +} {1 {wrong # args: should be "i1 option ?arg arg ...?"}} +test imageBmap-7.2 {ImgBmapCmd procedure, "cget" option} { + list [catch {i1 cget} msg] $msg +} {1 {wrong # args: should be "i1 cget option"}} +test imageBmap-7.3 {ImgBmapCmd procedure, "cget" option} { + list [catch {i1 cget a b} msg] $msg +} {1 {wrong # args: should be "i1 cget option"}} +test imageBmap-7.4 {ImgBmapCmd procedure, "cget" option} { + i1 co -foreground #123456 + i1 cget -foreground +} {#123456} +test imageBmap-7.5 {ImgBmapCmd procedure, "cget" option} { + list [catch {i1 cget -stupid} msg] $msg +} {1 {unknown option "-stupid"}} +test imageBmap-7.6 {ImgBmapCmd procedure} { + llength [i1 configure] +} {6} +test imageBmap-7.7 {ImgBmapCmd procedure} { + i1 co -foreground #001122 + i1 configure -foreground +} {-foreground {} {} #000000 #001122} +test imageBmap-7.8 {ImgBmapCmd procedure} { + list [catch {i1 configure -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test imageBmap-7.9 {ImgBmapCmd procedure} { + list [catch {i1 configure -foreground #221100 -background} msg] $msg +} {1 {value for "-background" missing}} +test imageBmap-7.10 {ImgBmapCmd procedure} { + list [catch {i1 gorp} msg] $msg +} {1 {bad option "gorp": must be cget or configure}} + +test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} { + eval image delete [image names] + .c delete all + image create bitmap i1 -data $data1 + .c create image 50 100 -image i1 -tags i1.1 + .c create image 150 100 -image i1 -tags i1.2 + .c create image 250 100 -image i1 -tags i1.3 + update + .c delete i1.1 + i1 configure -background black + update + .c delete i1.2 + i1 configure -background white + update + .c delete i1.3 + i1 configure -background black + update + image delete i1 +} {} + +test imageBmap-9.1 {ImgBmapDisplay procedure, nothing to display} { + proc bgerror args {} + eval image delete [image names] + .c delete all + image create bitmap i1 -data $data1 + .c create image 50 100 -image i1 -tags i1.1 + i1 configure -data {} + update +} {} +test imageBmap-9.2 {ImgBmapDisplay procedure, nothing to display} { + proc bgerror args {} + eval image delete [image names] + .c delete all + image create bitmap i1 -data $data1 + .c create image 50 100 -image i1 -tags i1.1 + i1 configure -foreground bogus + update +} {} +if {[info exists bgerror]} { + rename bgerror {} +} + +test imageBmap-10.1 {ImgBmapFree procedure, resource freeing} { + eval image delete [image names] + .c delete all + image create bitmap i1 -data $data1 -maskdata $data2 -foreground #112233 \ + -background #445566 + .c create image 100 100 -image i1 + update + .c delete all + image delete i1 +} {} +test imageBmap-10.2 {ImgBmapFree procedures, unlinking} { + eval image delete [image names] + .c delete all + image create bitmap i1 -data $data1 -maskdata $data2 -foreground #112233 \ + -background #445566 + .c create image 100 100 -image i1 + button .b1 -image i1 + button .b2 -image i1 + button .b3 -image i1 + pack .b1 .b2 .b3 + update + destroy .b2 + update + destroy .b3 + update + destroy .b1 + update + .c delete all +} {} + +test imageBmap-11.1 {ImgBmapDelete procedure} { + image create bitmap i2 -file foo.bm -maskfile foo2.bm + image delete i2 + info command i2 +} {} +test imageBmap-11.2 {ImgBmapDelete procedure} { + image create bitmap i2 -file foo.bm -maskfile foo2.bm + rename i2 newi2 + set x [list [info command i2] [info command new*] [newi2 cget -file]] + image delete i2 + lappend x [info command new*] +} {{} newi2 foo.bm {}} + +test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} { + image create bitmap i2 -file foo.bm -maskfile foo2.bm + rename i2 {} + list [lsearch -exact [image names] i2] [catch {i2 foo} msg] $msg +} {-1 1 {invalid command name "i2"}} + +removeFile foo.bm +removeFile foo2.bm +destroy .c +eval image delete [image names] diff --git a/tests/imgPPM.test b/tests/imgPPM.test new file mode 100644 index 0000000..044a274 --- /dev/null +++ b/tests/imgPPM.test @@ -0,0 +1,156 @@ +# This file is a Tcl script to test out the code in tkImgFmtPPM.c, +# which reads and write PPM-format image files for photo widgets. +# The files is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) imgPPM.test 1.14 97/10/28 14:47:05 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +eval image delete [image names] + +proc put {file data} { + set f [open $file w] + fconfigure $f -translation lf + puts -nonewline $f $data + close $f +} + +test imgPPM-1.1 {FileReadPPM procedure} { + put test.ppm "P6\n0 256\n255\nabcdef" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {PPM image file "test.ppm" has dimension(s) <= 0}} +test imgPPM-1.2 {FileReadPPM procedure} { + put test.ppm "P6\n-2 256\n255\nabcdef" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {PPM image file "test.ppm" has dimension(s) <= 0}} +test imgPPM-1.3 {FileReadPPM procedure} { + put test.ppm "P6\n10 0\n255\nabcdef" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {PPM image file "test.ppm" has dimension(s) <= 0}} +test imgPPM-1.4 {FileReadPPM procedure} { + put test.ppm "P6\n10 -2\n255\nabcdef" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {PPM image file "test.ppm" has dimension(s) <= 0}} +test imgPPM-1.5 {FileReadPPM procedure} { + put test.ppm "P6\n10 20\n256\nabcdef" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {PPM image file "test.ppm" has bad maximum intensity value 256}} +test imgPPM-1.6 {FileReadPPM procedure} { + put test.ppm "P6\n10 20\n0\nabcdef" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {PPM image file "test.ppm" has bad maximum intensity value 0}} +test imgPPM-1.7 {FileReadPPM procedure} { + put test.ppm "P6\n10 10\n255\nabcdef" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {error reading PPM image file "test.ppm": not enough data}} +test imgPPM-1.8 {FileReadPPM procedure} { + put test.ppm "P6\n5 4\n255\n01234567890123456789012345678901234567890123456789012345678" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {error reading PPM image file "test.ppm": not enough data}} +test imgPPM-1.9 {FileReadPPM procedure} { + put test.ppm "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg \ + [image width p1] [image height p1] +} {0 p1 5 4} + +catch {image delete p1} +put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" +image create photo p1 -file test.ppm +test imgPPM-2.1 {FileWritePPM procedure} { + list [catch {p1 write not_a_dir/bar/baz/gorp} msg] [string tolower $msg] \ + [string tolower $errorCode] +} {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 test2.ppm + set fd [open test2.ppm] + set data [read $fd] + close $fd + set data +} {P6 +5 4 +255 +012345678901234567890123456789012345678901234567890123456789} + +test imgPPM-3.1 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "# \n#\n#\nP6\n#\n##\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {0 p1} +test imgPPM-3.2 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "P6\n5\n 4 255\n012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {0 p1} +test imgPPM-3.3 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "P6\n# asdfasdf\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {0 p1} +test imgPPM-3.4 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "P6 \n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {0 p1} +test imgPPM-3.5 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "P5\n5 4\n255\n01234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {0 p1} +test imgPPM-3.6 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "P3\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {couldn't recognize data in image file "test.ppm"}} +test imgPPM-3.7 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "P6x\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {couldn't recognize data in image file "test.ppm"}} +test imgPPM-3.8 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "P6\nxy5 4\n255\n012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {couldn't recognize data in image file "test.ppm"}} +test imgPPM-3.9 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "P6\n5\n255\n!012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {couldn't recognize data in image file "test.ppm"}} +test imgPPM-3.10 {ReadPPMFileHeader procedure} { + catch {image delete p1} + put test.ppm "P6\n5 4\nzz255\n012345678901234567890123456789012345678901234567890123456789" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {couldn't recognize data in image file "test.ppm"}} +test imgPPM-3.11 {ReadPPMFileHeader procedure, empty file} { + catch {image delete p1} + put test.ppm " " + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {couldn't recognize data in image file "test.ppm"}} +test imgPPM-3.12 {ReadPPMFileHeader procedure, file ends too soon} { + catch {image delete p1} + put test.ppm "P6\n566" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {couldn't recognize data in image file "test.ppm"}} +test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} { + catch {image delete p1} + put test.ppm "P6\n566\n#asdf" + list [catch {image create photo p1 -file test.ppm} msg] $msg +} {1 {couldn't recognize data in image file "test.ppm"}} + +removeFile test.ppm +removeFile test2.ppm +eval image delete [image names] diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test new file mode 100644 index 0000000..ec7c635 --- /dev/null +++ b/tests/imgPhoto.test @@ -0,0 +1,423 @@ +# This file is a Tcl script to test out the "photo" image type and the +# other procedures in the file tkImgPhoto.c. It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Australian National University +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Author: Paul Mackerras (paulus@cs.anu.edu.au) +# +# SCCS: @(#) imgPhoto.test 1.23 97/08/08 11:29:25 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +eval image delete [image names] + +canvas .c +pack .c +update + +test imgPhoto-1.1 {options for photo images} { + image create photo p1 -width 79 -height 83 + list [lindex [p1 configure -width] 4] [lindex [p1 configure -height] 4] \ + [image width p1] [image height p1] +} {79 83 79 83} +test imgPhoto-1.2 {options for photo images} { + list [catch {image create photo p1 -file no.such.file} err] \ + [string tolower $err] +} {1 {couldn't open "no.such.file": no such file or directory}} +test imgPhoto-1.3 {options for photo images} { + list [catch {image create photo p1 -file \ + [file join $tk_library demos/images/teapot.ppm] \ + -format no.such.format} err] $err +} {1 {image file format "no.such.format" is not supported}} +test imgPhoto-1.4 {options for photo images} { + image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + list [image width p1] [image height p1] +} {256 256} +test imgPhoto-1.5 {options for photo images} { + image create photo p1 \ + -file [file join $tk_library demos/images/teapot.ppm] \ + -format ppm -width 79 -height 83 + list [image width p1] [image height p1] \ + [lindex [p1 configure -file] 4] [lindex [p1 configure -format] 4] +} [list 79 83 [file join $tk_library demos/images/teapot.ppm] ppm] +test imgPhoto-1.6 {options for photo images} { + image create photo p1 -palette 2/2/2 -gamma 2.2 + list [format %.1f [lindex [p1 configure -gamma] 4]] \ + [lindex [p1 configure -palette] 4] +} {2.2 2/2/2} +test imgPhoto-1.7 {options for photo images} { + list [catch {image create photo p1 -file README} err] $err +} {1 {couldn't recognize data in image file "README"}} +test imgPhoto-1.8 {options for photo images} { + list [catch {image create photo -blah blah} err] $err +} {1 {unknown option "-blah"}} + +test imgPhoto-2.1 {ImgPhotoCreate procedure} { + eval image delete [image names] + catch {image create photo -blah blah} + image names +} {} +test imgPhoto-2.2 {ImgPhotoCreate procedure} { + eval image delete [image names] + image create photo image1 + list [info commands image1] [image names] \ + [image width image1] [image height image1] +} {image1 image1 0 0} +# test imgPhoto-2.3 {ImgPhotoCreate procedure: creation failure} { +# image create photo p1 +# image create photo p2 -width 10 -height 10 +# catch {image create photo p2 -file bogus.img} msg +# p1 copy p2 +# set msg +# } {couldn't open "bogus.img": no such file or directory} + +test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} { + image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + p1 configure -file [file join $tk_library demos/images/teapot.ppm] +} {} +test imgPhoto-3.2 {ImgPhotoConfigureMaster procedure} { + image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + list [catch {p1 configure -file bogus} err] [string tolower $err] \ + [image width p1] [image height p1] +} {1 {couldn't open "bogus": no such file or directory} 256 256} +test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} { + image create photo p1 + .c create image 10 10 -image p1 -tags p1.1 -anchor nw + .c create image 300 10 -image p1 -tags p1.2 -anchor nw + update + p1 configure -file [file join $tk_library demos/images/teapot.ppm] + update + list [image width p1] [image height p1] [.c bbox p1.1] [.c bbox p1.2] +} {256 256 {10 10 266 266} {300 10 556 266}} + +eval image delete [image names] +image create photo p1 +.c create image 10 10 -image p1 +update + +test imgPhoto-4.1 {ImgPhotoCmd procedure} { + list [catch {p1} err] $err +} {1 {wrong # args: should be "p1 option ?arg arg ...?"}} +test imgPhoto-4.2 {ImgPhotoCmd procedure} { + list [catch {p1 blah} err] $err +} {1 {bad option "blah": must be blank, cget, configure, copy, get, put, read, redither, or write}} +test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} { + p1 blank + list [catch {p1 blank x} err] $err +} {1 {wrong # args: should be "p1 blank"}} +test imgPhoto-4.4 {ImgPhotoCmd procedure: cget option} { + list [catch {p1 cget} msg] $msg +} {1 {wrong # args: should be "p1 cget option"}} +test imgPhoto-4.5 {ImgPhotoCmd procedure: cget option} { + image create photo p2 -width 25 -height 30 + list [p2 cget -width] [p2 cget -height] +} {25 30} +test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} { + llength [p1 configure] +} {7} +test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} { + p1 conf -palette 3/4/2 + p1 configure -palette +} {-palette {} {} {} 3/4/2} +test imgPhoto-4.8 {ImgPhotoCmd procedure: configure option} { + list [catch {p1 configure -blah} msg] $msg +} {1 {unknown option "-blah"}} +test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} { + list [catch {p1 configure -palette {} -gamma} msg] $msg +} {1 {value for "-gamma" missing}} +test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} { + image create photo p2 -file [file join $tk_library demos/images/teapot.ppm] + p1 configure -width 0 -height 0 -palette {} -gamma 1 + p1 copy p2 + list [image width p1] [image height p1] [p1 get 100 100] +} {256 256 {169 117 90}} +test imgPhoto-4.11 {ImgPhotoCmd procedure: copy option} { + list [catch {p1 copy} msg] $msg +} {1 {wrong # args: should be "p1 copy source-image ?-from x1 y1 x2 y2? ?-to x1 y1 x2 y2? ?-zoom x y? ?-subsample x y?"}} +test imgPhoto-4.12 {ImgPhotoCmd procedure: copy option} { + list [catch {p1 copy blah} msg] $msg +} {1 {image "blah" doesn't exist or is not a photo image}} +test imgPhoto-4.13 {ImgPhotoCmd procedure: copy option} { + list [catch {p1 copy p2 -blah} msg] $msg +} {1 {unrecognized option "-blah": must be -from, -shrink, -subsample, -to, or -zoom}} +test imgPhoto-4.14 {ImgPhotoCmd procedure: copy option} { + list [catch {p1 copy p2 -from -to} msg] $msg +} {1 {the "-from" option requires one to four integer values}} +test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} { + p1 copy p2 + p1 copy p2 -from 0 70 60 120 -shrink + list [image width p1] [image height p1] [p1 get 20 10] +} {60 50 {215 154 120}} +test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} { + p1 copy p2 -from 60 120 0 70 -to 20 50 + list [image width p1] [image height p1] [p1 get 40 80] +} {80 100 {19 92 192}} +test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} { + p1 copy p2 -from 0 120 60 70 -to 0 0 100 100 + list [image width p1] [image height p1] [p1 get 80 60] +} {100 100 {215 154 120}} +test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} { + p1 copy p2 -from 60 70 0 120 -zoom 2 + list [image width p1] [image height p1] [p1 get 100 50] +} {120 100 {169 99 47}} +test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} { + p1 copy p2 -from 0 70 60 120 + list [image width p1] [image height p1] [p1 get 100 50] +} {120 100 {169 99 47}} +test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} { + p1 copy p2 -from 20 20 200 180 -subsample 2 -shrink + list [image width p1] [image height p1] [p1 get 50 30] +} {90 80 {207 146 112}} +test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} { + p1 copy p2 + set result [list [image width p1] [image height p1]] + p1 conf -width 49 -height 51 + lappend result [image width p1] [image height p1] + p1 copy p2 + lappend result [image width p1] [image height p1] + p1 copy p2 -from 0 0 10 10 -shrink + lappend result [image width p1] [image height p1] + p1 conf -width 0 + p1 copy p2 -from 0 0 10 10 -shrink + lappend result [image width p1] [image height p1] + p1 conf -height 0 + p1 copy p2 -from 0 0 10 10 -shrink + lappend result [image width p1] [image height p1] +} {256 256 49 51 49 51 49 51 10 51 10 10} +test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} { + p1 read [file join $tk_library demos/images/teapot.ppm] + list [p1 get 100 100] [p1 get 150 100] [p1 get 100 150] +} {{169 117 90} {172 115 84} {35 35 35}} +test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} { + list [catch {p1 get 256 0} err] $err +} {1 {p1 get: coordinates out of range}} +test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} { + list [catch {p1 get 0 -1} err] $err +} {1 {p1 get: coordinates out of range}} +test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} { + list [catch {p1 get} err] $err +} {1 {wrong # args: should be "p1 get x y"}} +test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} { + list [catch {p1 put} err] $err +} {1 {wrong # args: should be "p1 put {{colors...}...} ?-to x1 y1 x2 y2?"}} +test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} { + list [catch {p1 put {{white} {white white}}} err] $err +} {1 {all elements of color list must have the same number of elements}} +test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} { + list [catch {p1 put {{blahgle}}} err] $err +} {1 {can't parse color "blahgle"}} +test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} { + p1 put -to 10 10 20 20 {{white}} + p1 get 19 19 +} {255 255 255} +test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} { + list [catch {p1 read} err] $err +} {1 {wrong # args: should be "p1 read fileName ?-format format-name? ?-from x1 y1 x2 y2? ?-to x y? ?-shrink?"}} +test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} { + list [catch {p1 read [file join $tk_library demos/images/teapot.ppm] \ + -zoom 2} err] $err +} {1 {unrecognized option "-zoom": must be -format, -from, -shrink, or -to}} +test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} { + list [catch {p1 read bogus} err] [string tolower $err] +} {1 {couldn't open "bogus": no such file or directory}} +test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} { + list [catch {p1 read [file join $tk_library demos/images/teapot.ppm] \ + -format bogus} err] $err +} {1 {image file format "bogus" is not supported}} +test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} { + list [catch {p1 read README} err] $err +} {1 {couldn't recognize data in image file "README"}} +test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} { + p1 read [file join $tk_library demos/images/teapot.ppm] -shrink + list [image width p1] [image height p1] [p1 get 120 120] +} {256 256 {161 109 82}} +test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} { + p1 read [file join $tk_library demos/images/teapot.ppm] \ + -from 0 70 60 120 -to 10 10 -shrink + list [image width p1] [image height p1] [p1 get 29 19] +} {70 60 {244 180 144}} +test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} { + p1 redither + list [catch {p1 redither x} err] $err +} {1 {wrong # args: should be "p1 redither"}} +test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} { + list [catch {p1 write} err] $err +} {1 {wrong # args: should be "p1 write fileName ?-format format-name??-from x1 y1 x2 y2?"}} +test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} { + list [catch {p1 write teapot.tmp -format bogus} err] $err +} {1 {image file format "bogus" is unknown}} + +test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} { + eval image delete [image names] + .c delete all + image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + .c create image 0 0 -image p1 -tags p1.1 + .c create image 256 0 -image p1 -tags p1.2 + .c create image 0 256 -image p1 -tags p1.3 + update + .c delete i1.1 + p1 configure -width 1 + update + .c delete i1.2 + p1 configure -height 1 + update + image delete p1 +} {} + +test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} { + .c delete all + image create photo p1 -width 10 -height 10 + p1 blank + .c create image 10 10 -image p1 + update +} {} + +test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} { + eval image delete [image names] + .c delete all + image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + .c create image 0 0 -image p1 -anchor nw + update + .c delete all + image delete p1 +} {} +test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} { + image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + .c create image 10 10 -image p1 -anchor nw + button .b1 -image p1 + button .b2 -image p1 + button .b3 -image p1 + pack .b1 .b2 .b3 + update + destroy .b2 + update + destroy .b3 + update + destroy .b1 + update + .c delete all +} {} +test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} { + image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + button .b1 -image p1 + frame .f -visual best + button .f.b2 -image p1 + pack .f.b2 + pack .b1 .f + update + destroy .b1 + update + .f.b2 configure -image {} + update + destroy .f + image delete p1 +} {} + +test imgPhoto-8.1 {ImgPhotoDelete procedure} { + image create photo p2 -file [file join $tk_library demos/images/teapot.ppm] + image delete p2 +} {} +test imagePhoto-8.2 {ImgPhotoDelete procedure} { + image create photo p2 -file [file join $tk_library demos/images/teapot.ppm] + rename p2 newp2 + set x [list [info command p2] [info command new*] [newp2 cget -file]] + image delete p2 + lappend x [info command new*] +} [list {} newp2 [file join $tk_library demos/images/teapot.ppm] {}] +test imagePhoto-8.3 {ImgPhotoDelete procedure, name cleanup} { + image create photo p1 + image create photo p2 -width 10 -height 10 + image delete p2 + list [catch {p1 copy p2} msg] $msg +} {1 {image "p2" doesn't exist or is not a photo image}} + +test imagePhoto-9.1 {ImgPhotoCmdDeletedProc procedure} { + image create photo p2 -file [file join $tk_library demos/images/teapot.ppm] + rename p2 {} + list [lsearch -exact [image names] p2] [catch {p2 foo} msg] $msg +} {-1 1 {invalid command name "p2"}} + +test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} { + eval image delete [image names] + image create photo p1 + p1 put {{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}} \ + -to 0 0 + p1 put {{#00ff00 #00ff00}} -to 2 0 + list [p1 get 2 0] [p1 get 3 0] [p1 get 4 0] +} {{0 255 0} {0 255 0} {255 0 0}} + +test imgPhoto-11.1 {Tk_FindPhoto} { + eval image delete [image names] + image create bitmap i1 + image create photo p1 + list [catch {p1 copy i1} msg] $msg +} {1 {image "i1" doesn't exist or is not a photo image}} + +test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} { + image create photo p3 -file [file join $tk_library demos/images/teapot.ppm] + set result [list [p3 get 50 50] [p3 get 100 100]] + p3 copy p3 -zoom 2 + lappend result [image width p3] [image height p3] [p3 get 100 100] + image delete p3 + set result +} {{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] + set data { + R0lGODlhQgBkAPUAANbWxs7Wxs7OxsbOxsbGxsbGvb3Gvca9vcDAwL21vbW1vbW1tbWtta2t + ta2ltaWltaWlraWctaWcrZycrZyUrZSUrZSMrZSMpYyMrYyMpYyEpYSEpYR7pYR7nHp7pYRz + pYRynHtzpXtznHtrnHNrnHNjnGtjnGtjlGtalGNalGNSlGNSjFpSlFpKlFpKjFJKjFJCjFI5 + jEo5jEo5hEoxhEIxhDkphDkhhAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAQgBkAAAG + /kCEcEgsGo/IpHLJbDqf0Kh0Sq1ar9isdsvter/gsHhMLpvP6LR6zW673/C4fE6v2+/4vH7P + 7/v/gIGCg4SFhoeIiYqLjI2Oj5CRkpOUlZaXmJmOBZxXnAQEnKIIBUQJCguoDKkIBgWhpUev + CA4TDwgEUpwKERUaHCIiJCQjIiEUQhwqKiwqLjDQMCwoIha3oUO5ESMuLSwtLSIMsU4Tzi4o + JBwWFA8ODQoMCkIMq6sNDQ4UFhwlzC4qSGhgkMvCsAoM6E0oAWMCOSUFGrgQcauAgAACSqGa + l6SAK1EaJXBA0SIDBw0KBiCg8EtEBgEWYCxoooAigFwIJGgQYQIF/goTAjk6sXhxAwwFnHRO + mEmAwoQAIUo8lCWhRgoOElJVkJBQFCwhCRqkYlUE1QMKHEywoBCrQaeIMCgQeOCi3AkYMmRI + S5EuxEkN7OApkGDhF4fDxoSVMAFUBAWkRxI0a+XghVAkBSqMsFCBwj4OI0igSKGCdLN0wYKd + zGDBwUYhn6YOKUCioQECGk7INpIArQgUKkr87TyhAYIDQxQgLkYsRIcQIDjcgi2Lw8RYKaAz + MXCgAs8UJrZGmOA5AkeQBlqRKsIpvYMQDx4S4NCCxIJSKJpFYMIgnPlSF2ygAQWuCUHAAp6x + E4EEE5BXQQUWYLABBySoAIMLHBSBWwso/jxwIAoyzMAWEw3AEEJCt6nUwAQagCDCYcCQwJcK + 6QD3DDQxwNDCCSg9NIAGKpwwgQAOtDADDBbsdkQDIPhkwosDPgDPAg1EAME++1jTnhAKdAnb + VAR04EIJFAhwwQs0sBDfE7cZwEAE++yU2joOtDcKE7GUcoIKH6RSmwwnQCZFKAo8cE2es7my + HnuxKTDgAA6owEEBjoL3wqRUNDBCCnyRYMFMRSDoWYPvyBPPA738lt1KKTxgpjolrDDiFAWU + cAMKE+CipAMRZMDTCSSUQMIJPQHLwWOcrDKBCBpokAIJgmYqQgosxIAOCS8iJEQD7HR2QbMh + WCCEK7Ck90Cz/oAFu+YVigpTwTsLyJOcBJ6N6plxRihA3E4cOKTkFCU6FMoAA7wiygAZgURA + ekYsEJYFGTSATRccQEMjti8eZsEFFuA7z2WkEJAAl7iEQekEhQHGzgQR4INUKLB8pYAFJaQA + KhleKdwAByEkFswHIoxQQn4AcYBvGRosisDICCjQAIMJGnZYBsUd4JEZBIhQwgPzKFwAwggL + IHbOQzCtxZ1NL0BlKmmhIOwwHGTg2YMUEBdtKzBfbQWlhMHoHIXBnvABBGE9UMKNMKhgQgnG + nNQO0wVQoI4FEohFyr9GzDIYaaPxxWy0rCjKQJUMQvxBaMOgNMQChcU4DAkZ6PoV/hIUoP4i + Z7g/YHZHIPXeyWyONgsaCi4AOoLjXP8uhAAvPpCQ2Akr38UpXW60Ij8yPkMmwwj8KAI8QWtQ + +eXSixEb37WhcHQBERz2rdZ8leCBBcXNY3XevQ8VG/6+F5CACDYgATlmYYD27aRmLngBNADC + GGxxQEAWUJDzqpcctc2DARN4kNRgtJxhnKAFV0kIEhYAJ34IQwUhqkENYFCCE5BmGf9wwWmA + 5UGgXAAVtfCFMIgRLMbFLQIPYFACcMI7TjQoH2eJQIs2poEMYMAp5XGAvFrBCYS9ImzQG1vT + arGTEQhIhE7QjLA+MKDOxClGwuoJtWi0uBIUIxjDSE2wQ4iHl7ywQDjGwZws/NcAlgBjaKQJ + JDVuoQBeUeACoFkMcFqgQL1IgxpRSsjsqHA/gy0tHvmAx2z2BxIupaJrnVxCEAAAOw== + } + interp create x1 + interp create x2 + x1 eval {load {} Tk} + x2 eval {load {} Tk} + x1 eval [list image create photo T1_data -data $data] + x2 eval [list image create photo T1_data -data $data] + unset data + interp delete x1 + interp delete x2 +} {} + +destroy .c +eval image delete [image names] diff --git a/tests/listbox.test b/tests/listbox.test new file mode 100644 index 0000000..cb1a4e3 --- /dev/null +++ b/tests/listbox.test @@ -0,0 +1,1658 @@ +# This file is a Tcl script to test out the "listbox" command +# of Tk. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1993-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) listbox.test 1.45 97/10/29 13:05:46 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . +set fixed {Courier -12} + +proc record args { + global log + lappend log $args +} + +proc getsize w { + regexp {(^[^+-]*)} [wm geometry $w] foo x + return $x +} + +proc resetGridInfo {} { + # Some window managers, such as mwm, don't reset gridding information + # unless the window is withdrawn and re-mapped. If this procedure + # isn't invoked, the window manager will stay in gridded mode, which + # can cause all sorts of problems. The "wm positionfrom" command is + # needed so that the window manager doesn't ask the user to + # manually position the window when it is re-mapped. + + wm withdraw . + wm positionfrom . user + wm deiconify . +} + +# Procedure that creates a second listbox for checking things related +# to partially visible lines. + +proc mkPartial {{w .partial}} { + catch {destroy $w} + toplevel $w + wm geometry $w +0+0 + listbox $w.l -width 30 -height 5 + pack $w.l -expand 1 -fill both + $w.l insert end one two three four five six seven eight nine ten \ + eleven twelve thirteen fourteen fifteen + update + scan [wm geometry $w] "%dx%d" width height + wm geometry $w ${width}x[expr $height-3] + update +} + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Listbox.borderWidth 2 +option add *Listbox.highlightThickness 2 +option add *Listbox.font {Helvetica -12 bold} + +listbox .l +pack .l +update +resetGridInfo +set i 1 + +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"}} + {-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}} + {-fg #110022 #110022 bogus {unknown color name "bogus"}} + {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} + {-foreground #110022 #110022 bogus {unknown color name "bogus"}} + {-height 30 30 20p {expected integer but got "20p"}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} + {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}} + {-highlightthickness 6 6 bogus {bad screen distance "bogus"}} + {-highlightthickness -2 0 {} {}} + {-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"}} + {-selectmode string string {} {}} + {-setgrid false 0 lousy {expected boolean value but got "lousy"}} + {-takefocus "any string" "any string" {} {}} + {-width 45 45 3p {expected integer but got "3p"}} + {-xscrollcommand {Some command} {Some command} {} {}} + {-yscrollcommand {Another command} {Another command} {} {}} +} { + set name [lindex $test 0] + test listbox-1.$i {configuration options} { + .l configure $name [lindex $test 1] + list [lindex [.l configure $name] 4] [.l cget $name] + } [list [lindex $test 2] [lindex $test 2]] + incr i + if {[lindex $test 3] != ""} { + test listbox-1.$i {configuration options} { + list [catch {.l configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .l configure $name [lindex [.l configure $name] 3] + incr i +} + +test listbox-2.1 {Tk_ListboxCmd procedure} { + list [catch {listbox} msg] $msg +} {1 {wrong # args: should be "listbox pathName ?options?"}} +test listbox-2.2 {Tk_ListboxCmd procedure} { + list [catch {listbox gorp} msg] $msg +} {1 {bad window path name "gorp"}} +test listbox-2.3 {Tk_ListboxCmd procedure} { + catch {destroy .l} + listbox .l + list [winfo exists .l] [winfo class .l] [info commands .l] +} {1 Listbox .l} +test listbox-2.4 {Tk_ListboxCmd procedure} { + catch {destroy .l} + list [catch {listbox .l -gorp foo} msg] $msg [winfo exists .l] \ + [info commands .l] +} {1 {unknown option "-gorp"} 0 {}} +test listbox-2.5 {Tk_ListboxCmd procedure} { + catch {destroy .l} + listbox .l +} {.l} + +catch {destroy .l} +listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2 +pack .l +.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \ + el15 el16 el17 +update +test listbox-3.1 {ListboxWidgetCmd procedure} { + list [catch .l msg] $msg +} {1 {wrong # args: should be ".l option ?arg arg ...?"}} +test listbox-3.2 {ListboxWidgetCmd procedure, "activate" option} { + list [catch {.l activate} msg] $msg +} {1 {wrong # args: should be ".l activate index"}} +test listbox-3.3 {ListboxWidgetCmd procedure, "activate" option} { + list [catch {.l activate a b} msg] $msg +} {1 {wrong # args: should be ".l activate index"}} +test listbox-3.4 {ListboxWidgetCmd procedure, "activate" option} { + list [catch {.l activate fooey} msg] $msg +} {1 {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}} +test listbox-3.5 {ListboxWidgetCmd procedure, "activate" option} { + .l activate 3 + .l index active +} 3 +test listbox-3.6 {ListboxWidgetCmd procedure, "activate" option} { + .l activate -1 + .l index active +} {0} +test listbox-3.7 {ListboxWidgetCmd procedure, "activate" option} { + .l activate 30 + .l index active +} {17} +test listbox-3.8 {ListboxWidgetCmd procedure, "activate" option} { + .l activate end + .l index active +} {17} +test listbox-3.9 {ListboxWidgetCmd procedure, "bbox" option} { + list [catch {.l bbox} msg] $msg +} {1 {wrong # args: should be ".l bbox index"}} +test listbox-3.10 {ListboxWidgetCmd procedure, "bbox" option} { + list [catch {.l bbox a b} msg] $msg +} {1 {wrong # args: should be ".l bbox index"}} +test listbox-3.11 {ListboxWidgetCmd procedure, "bbox" option} { + list [catch {.l bbox fooey} msg] $msg +} {1 {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}} +test listbox-3.12 {ListboxWidgetCmd procedure, "bbox" option} { + .l yview 3 + update + list [.l bbox 2] [.l bbox 8] +} {{} {}} +test listbox-3.13 {ListboxWidgetCmd procedure, "bbox" option} { + # Used to generate a core dump before a bug was fixed (the last + # element would be on-screen if it existed, but it doesn't exist). + + listbox .l2 + pack .l2 -side top + tkwait visibility .l2 + set x [.l2 bbox 0] + destroy .l2 + set x +} {} +test listbox-3.14 {ListboxWidgetCmd procedure, "bbox" option} {fonts} { + .l yview 3 + update + list [.l bbox 3] [.l bbox 4] +} {{7 7 17 14} {7 26 17 14}} +test listbox-3.15 {ListboxWidgetCmd procedure, "bbox" option} {fonts} { + .l yview 0 + update + list [.l bbox -1] [.l bbox 0] +} {{} {7 7 17 14}} +test listbox-3.16 {ListboxWidgetCmd procedure, "bbox" option} {fonts} { + .l yview end + update + list [.l bbox 17] [.l bbox end] [.l bbox 18] +} {{7 83 24 14} {7 83 24 14} {}} +test listbox-3.17 {ListboxWidgetCmd procedure, "bbox" option} {fonts} { + catch {destroy .t} + toplevel .t + wm geom .t +0+0 + listbox .t.l -width 10 -height 5 + .t.l insert 0 "Short" "Somewhat longer" "Really, quite a whole lot longer than can possibly fit on the screen" "Short" + pack .t.l + update + .t.l xview moveto .2 + .t.l bbox 2 +} {-72 39 393 14} +test listbox-3.18 {ListboxWidgetCmd procedure, "bbox" option, partial last line} {fonts} { + mkPartial + list [.partial.l bbox 3] [.partial.l bbox 4] +} {{5 56 24 14} {5 73 23 14}} +test listbox-3.19 {ListboxWidgetCmd procedure, "cget" option} { + list [catch {.l cget} msg] $msg +} {1 {wrong # args: should be ".l cget option"}} +test listbox-3.20 {ListboxWidgetCmd procedure, "cget" option} { + list [catch {.l cget a b} msg] $msg +} {1 {wrong # args: should be ".l cget option"}} +test listbox-3.21 {ListboxWidgetCmd procedure, "cget" option} { + list [catch {.l cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} { + .l cget -setgrid +} {0} +test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} { + llength [.l configure] +} {23} +test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} { + list [catch {.l configure -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test listbox-3.25 {ListboxWidgetCmd procedure, "configure" option} { + .l configure -setgrid +} {-setgrid setGrid SetGrid 0 0} +test listbox-3.26 {ListboxWidgetCmd procedure, "configure" option} { + list [catch {.l configure -gorp is_messy} msg] $msg +} {1 {unknown option "-gorp"}} +test listbox-3.27 {ListboxWidgetCmd procedure, "configure" option} { + set oldbd [.l cget -bd] + set oldht [.l cget -highlightthickness] + .l configure -bd 3 -highlightthickness 0 + set x "[.l cget -bd] [.l cget -highlightthickness]" + .l configure -bd $oldbd -highlightthickness $oldht + set x +} {3 0} +test listbox-3.28 {ListboxWidgetCmd procedure, "curselection" option} { + list [catch {.l curselection a} msg] $msg +} {1 {wrong # args: should be ".l curselection"}} +test listbox-3.29 {ListboxWidgetCmd procedure, "curselection" option} { + .l selection clear 0 end + .l selection set 3 6 + .l selection set 9 + .l curselection +} {3 4 5 6 9} +test listbox-3.30 {ListboxWidgetCmd procedure, "delete" option} { + list [catch {.l delete} msg] $msg +} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}} +test listbox-3.31 {ListboxWidgetCmd procedure, "delete" option} { + list [catch {.l delete a b c} msg] $msg +} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}} +test listbox-3.32 {ListboxWidgetCmd procedure, "delete" option} { + list [catch {.l delete badIndex} msg] $msg +} {1 {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}} +test listbox-3.33 {ListboxWidgetCmd procedure, "delete" option} { + list [catch {.l delete 2 123ab} msg] $msg +} {1 {bad listbox index "123ab": must be active, anchor, end, @x,y, or a number}} +test listbox-3.34 {ListboxWidgetCmd procedure, "delete" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 + .l2 delete 3 + list [.l2 get 2] [.l2 get 3] [.l2 index end] +} {el2 el4 7} +test listbox-3.35 {ListboxWidgetCmd procedure, "delete" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 + .l2 delete 2 4 + list [.l2 get 1] [.l2 get 2] [.l2 index end] +} {el1 el5 5} +test listbox-3.36 {ListboxWidgetCmd procedure, "delete" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 + .l2 delete -3 2 + .l2 get 0 end +} {el3 el4 el5 el6 el7} +test listbox-3.37 {ListboxWidgetCmd procedure, "delete" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 + .l2 delete -3 -1 + .l2 get 0 end +} {el0 el1 el2 el3 el4 el5 el6 el7} +test listbox-3.38 {ListboxWidgetCmd procedure, "delete" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 + .l2 delete 2 end + .l2 get 0 end +} {el0 el1} +test listbox-3.39 {ListboxWidgetCmd procedure, "delete" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 + .l2 delete 5 20 + .l2 get 0 end +} {el0 el1 el2 el3 el4} +test listbox-3.40 {ListboxWidgetCmd procedure, "delete" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 + .l2 delete end 20 + .l2 get 0 end +} {el0 el1 el2 el3 el4 el5 el6} +test listbox-3.41 {ListboxWidgetCmd procedure, "delete" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 + .l2 delete 8 20 + .l2 get 0 end +} {el0 el1 el2 el3 el4 el5 el6 el7} +test listbox-3.42 {ListboxWidgetCmd procedure, "get" option} { + list [catch {.l get} msg] $msg +} {1 {wrong # args: should be ".l get first ?last?"}} +test listbox-3.43 {ListboxWidgetCmd procedure, "get" option} { + list [catch {.l get a b c} msg] $msg +} {1 {wrong # args: should be ".l get first ?last?"}} +test listbox-3.44 {ListboxWidgetCmd procedure, "get" option} { + list [catch {.l get 2.4} msg] $msg +} {1 {bad listbox index "2.4": must be active, anchor, end, @x,y, or a number}} +test listbox-3.45 {ListboxWidgetCmd procedure, "get" option} { + list [catch {.l get end bogus} msg] $msg +} {1 {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}} +test listbox-3.46 {ListboxWidgetCmd procedure, "get" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 + list [.l2 get 0] [.l2 get 3] [.l2 get end] +} {el0 el3 el7} +test listbox-3.47 {ListboxWidgetCmd procedure, "get" option} { + catch {destroy .l2} + listbox .l2 + list [.l2 get 0] [.l2 get end] +} {{} {}} +test listbox-3.48 {ListboxWidgetCmd procedure, "get" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 el0 el1 el2 "two words" el4 el5 el6 el7 + .l2 get 3 end +} {{two words} el4 el5 el6 el7} +test listbox-3.49 {ListboxWidgetCmd procedure, "get" option} { + .l get -1 +} {} +test listbox-3.50 {ListboxWidgetCmd procedure, "get" option} { + .l get -2 -1 +} {} +test listbox-3.51 {ListboxWidgetCmd procedure, "get" option} { + .l get -2 3 +} {el0 el1 el2 el3} +test listbox-3.52 {ListboxWidgetCmd procedure, "get" option} { + .l get 12 end +} {el12 el13 el14 el15 el16 el17} +test listbox-3.53 {ListboxWidgetCmd procedure, "get" option} { + .l get 12 20 +} {el12 el13 el14 el15 el16 el17} +test listbox-3.54 {ListboxWidgetCmd procedure, "get" option} { + .l get end +} {el17} +test listbox-3.55 {ListboxWidgetCmd procedure, "get" option} { + .l get 30 +} {} +test listbox-3.56 {ListboxWidgetCmd procedure, "get" option} { + .l get 30 35 +} {} +test listbox-3.57 {ListboxWidgetCmd procedure, "index" option} { + list [catch {.l index} msg] $msg +} {1 {wrong # args: should be ".l index index"}} +test listbox-3.58 {ListboxWidgetCmd procedure, "index" option} { + list [catch {.l index a b} msg] $msg +} {1 {wrong # args: should be ".l index index"}} +test listbox-3.59 {ListboxWidgetCmd procedure, "index" option} { + list [catch {.l index @} msg] $msg +} {1 {bad listbox index "@": must be active, anchor, end, @x,y, or a number}} +test listbox-3.60 {ListboxWidgetCmd procedure, "index" option} { + .l index 2 +} 2 +test listbox-3.61 {ListboxWidgetCmd procedure, "index" option} { + .l index -1 +} -1 +test listbox-3.62 {ListboxWidgetCmd procedure, "index" option} { + .l index end +} 18 +test listbox-3.63 {ListboxWidgetCmd procedure, "index" option} { + .l index 34 +} 34 +test listbox-3.64 {ListboxWidgetCmd procedure, "insert" option} { + list [catch {.l insert} msg] $msg +} {1 {wrong # args: should be ".l insert index ?element element ...?"}} +test listbox-3.65 {ListboxWidgetCmd procedure, "insert" option} { + list [catch {.l insert badIndex} msg] $msg +} {1 {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}} +test listbox-3.66 {ListboxWidgetCmd procedure, "insert" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert end a b c d e + .l2 insert 3 x y z + .l2 get 0 end +} {a b c x y z d e} +test listbox-3.67 {ListboxWidgetCmd procedure, "insert" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert end a b c + .l2 insert -1 x + .l2 get 0 end +} {x a b c} +test listbox-3.68 {ListboxWidgetCmd procedure, "insert" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert end a b c + .l2 insert end x + .l2 get 0 end +} {a b c x} +test listbox-3.69 {ListboxWidgetCmd procedure, "insert" option} { + catch {destroy .l2} + listbox .l2 + .l2 insert end a b c + .l2 insert 43 x + .l2 get 0 end +} {a b c x} +test listbox-3.70 {ListboxWidgetCmd procedure, "nearest" option} { + list [catch {.l nearest} msg] $msg +} {1 {wrong # args: should be ".l nearest y"}} +test listbox-3.71 {ListboxWidgetCmd procedure, "nearest" option} { + list [catch {.l nearest a b} msg] $msg +} {1 {wrong # args: should be ".l nearest y"}} +test listbox-3.72 {ListboxWidgetCmd procedure, "nearest" option} { + list [catch {.l nearest 20p} msg] $msg +} {1 {expected integer but got "20p"}} +test listbox-3.73 {ListboxWidgetCmd procedure, "nearest" option} { + .l yview 3 + .l nearest 1000 +} {7} +test listbox-3.74 {ListboxWidgetCmd procedure, "scan" option} { + list [catch {.l scan a b} msg] $msg +} {1 {wrong # args: should be ".l scan mark|dragto x y"}} +test listbox-3.75 {ListboxWidgetCmd procedure, "scan" option} { + list [catch {.l scan a b c d} msg] $msg +} {1 {wrong # args: should be ".l scan mark|dragto x y"}} +test listbox-3.76 {ListboxWidgetCmd procedure, "scan" option} { + list [catch {.l scan foo bogus 2} msg] $msg +} {1 {expected integer but got "bogus"}} +test listbox-3.77 {ListboxWidgetCmd procedure, "scan" option} { + list [catch {.l scan foo 2 2.3} msg] $msg +} {1 {expected integer but got "2.3"}} +test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} {fonts} { + catch {destroy .t} + toplevel .t + wm geom .t +0+0 + listbox .t.l -width 10 -height 5 + .t.l insert 0 "Short" "Somewhat longer" "Really, quite a whole lot longer than can possibly fit on the screen" "Short" a b c d e f g h i j + pack .t.l + update + .t.l scan mark 100 140 + .t.l scan dragto 90 137 + update + list [.t.l xview] [.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 +} {1 {bad scan option "foo": must be mark or dragto}} +test listbox-3.80 {ListboxWidgetCmd procedure, "see" option} { + list [catch {.l see} msg] $msg +} {1 {wrong # args: should be ".l see index"}} +test listbox-3.81 {ListboxWidgetCmd procedure, "see" option} { + list [catch {.l see a b} msg] $msg +} {1 {wrong # args: should be ".l see index"}} +test listbox-3.82 {ListboxWidgetCmd procedure, "see" option} { + list [catch {.l see gorp} msg] $msg +} {1 {bad listbox index "gorp": must be active, anchor, end, @x,y, or a number}} +test listbox-3.83 {ListboxWidgetCmd procedure, "see" option} { + .l yview 7 + .l see 7 + .l index @0,0 +} {7} +test listbox-3.84 {ListboxWidgetCmd procedure, "see" option} { + .l yview 7 + .l see 11 + .l index @0,0 +} {7} +test listbox-3.85 {ListboxWidgetCmd procedure, "see" option} { + .l yview 7 + .l see 6 + .l index @0,0 +} {6} +test listbox-3.86 {ListboxWidgetCmd procedure, "see" option} { + .l yview 7 + .l see 5 + .l index @0,0 +} {3} +test listbox-3.87 {ListboxWidgetCmd procedure, "see" option} { + .l yview 7 + .l see 12 + .l index @0,0 +} {8} +test listbox-3.88 {ListboxWidgetCmd procedure, "see" option} { + .l yview 7 + .l see 13 + .l index @0,0 +} {11} +test listbox-3.89 {ListboxWidgetCmd procedure, "see" option} { + .l yview 7 + .l see -1 + .l index @0,0 +} {0} +test listbox-3.90 {ListboxWidgetCmd procedure, "see" option} { + .l yview 7 + .l see end + .l index @0,0 +} {13} +test listbox-3.91 {ListboxWidgetCmd procedure, "see" option} { + .l yview 7 + .l see 322 + .l index @0,0 +} {13} +test listbox-3.92 {ListboxWidgetCmd procedure, "see" option, partial last line} { + mkPartial + .partial.l see 4 + .partial.l index @0,0 +} {1} +test listbox-3.93 {ListboxWidgetCmd procedure, "selection" option} { + list [catch {.l select a} msg] $msg +} {1 {wrong # args: should be ".l selection option index ?index?"}} +test listbox-3.94 {ListboxWidgetCmd procedure, "selection" option} { + list [catch {.l select a b c d} msg] $msg +} {1 {wrong # args: should be ".l selection option index ?index?"}} +test listbox-3.95 {ListboxWidgetCmd procedure, "selection" option} { + list [catch {.l selection a bogus} msg] $msg +} {1 {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}} +test listbox-3.96 {ListboxWidgetCmd procedure, "selection" option} { + list [catch {.l selection a 0 lousy} msg] $msg +} {1 {bad listbox index "lousy": must be active, anchor, end, @x,y, or a number}} +test listbox-3.97 {ListboxWidgetCmd procedure, "selection" option} { + list [catch {.l selection anchor 0 0} msg] $msg +} {1 {wrong # args: should be ".l selection anchor index"}} +test listbox-3.98 {ListboxWidgetCmd procedure, "selection" option} { + list [.l selection anchor 5; .l index anchor] \ + [.l selection anchor 0; .l index anchor] +} {5 0} +test listbox-3.99 {ListboxWidgetCmd procedure, "selection" option} { + .l selection anchor -1 + .l index anchor +} {0} +test listbox-3.100 {ListboxWidgetCmd procedure, "selection" option} { + .l selection anchor end + .l index anchor +} {17} +test listbox-3.101 {ListboxWidgetCmd procedure, "selection" option} { + .l selection anchor 44 + .l index anchor +} {17} +test listbox-3.102 {ListboxWidgetCmd procedure, "selection" option} { + .l selection clear 0 end + .l selection set 2 8 + .l selection clear 3 4 + .l curselection +} {2 5 6 7 8} +test listbox-3.103 {ListboxWidgetCmd procedure, "selection" option} { + list [catch {.l selection includes 0 0} msg] $msg +} {1 {wrong # args: should be ".l selection includes index"}} +test listbox-3.104 {ListboxWidgetCmd procedure, "selection" option} { + .l selection clear 0 end + .l selection set 2 8 + .l selection clear 4 + list [.l selection includes 3] [.l selection includes 4] \ + [.l selection includes 5] +} {1 0 1} +test listbox-3.105 {ListboxWidgetCmd procedure, "selection" option} { + .l selection set 0 end + .l selection includes -1 +} {0} +test listbox-3.106 {ListboxWidgetCmd procedure, "selection" option} { + .l selection clear 0 end + .l selection set end + .l selection includes end +} {1} +test listbox-3.107 {ListboxWidgetCmd procedure, "selection" option} { + .l selection set 0 end + .l selection includes 44 +} {0} +test listbox-3.108 {ListboxWidgetCmd procedure, "selection" option} { + catch {destroy .l2} + listbox .l2 + .l2 selection includes 0 +} {0} +test listbox-3.109 {ListboxWidgetCmd procedure, "selection" option} { + .l selection clear 0 end + .l selection set 2 + .l selection set 5 7 + .l curselection +} {2 5 6 7} +test listbox-3.110 {ListboxWidgetCmd procedure, "selection" option} { + .l selection set 5 7 + .l curselection +} {2 5 6 7} +test listbox-3.111 {ListboxWidgetCmd procedure, "selection" option} { + list [catch {.l selection badOption 0 0} msg] $msg +} {1 {bad selection option "badOption": must be anchor, clear, includes, or set}} +test listbox-3.112 {ListboxWidgetCmd procedure, "size" option} { + list [catch {.l size a} msg] $msg +} {1 {wrong # args: should be ".l size"}} +test listbox-3.113 {ListboxWidgetCmd procedure, "size" option} { + .l size +} {18} +test listbox-3.114 {ListboxWidgetCmd procedure, "xview" option} { + catch {destroy .l2} + listbox .l2 + update + .l2 xview +} {0 1} +test listbox-3.115 {ListboxWidgetCmd procedure, "xview" option} { + catch {destroy .l} + listbox .l -width 10 -height 5 -font $fixed + .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 +} {0 1} +catch {destroy .l} +listbox .l -width 10 -height 5 -font $fixed +.l insert 0 a b c d e f g h i j k l m n o p q r s t +.l insert 1 "0123456789a123456789b123456789c123456789d123456789" +pack .l +update +test listbox-3.116 {ListboxWidgetCmd procedure, "xview" option} {fonts} { + .l xview 4 + .l xview +} {0.08 0.28} +test listbox-3.117 {ListboxWidgetCmd procedure, "xview" option} { + list [catch {.l xview foo} msg] $msg +} {1 {expected integer but got "foo"}} +test listbox-3.118 {ListboxWidgetCmd procedure, "xview" option} { + list [catch {.l xview zoom a b} msg] $msg +} {1 {unknown option "zoom": must be moveto or scroll}} +test listbox-3.119 {ListboxWidgetCmd procedure, "xview" option} {fonts} { + .l xview 0 + .l xview moveto .4 + update + .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 +} {0.04 0.24} +test listbox-3.121 {ListboxWidgetCmd procedure, "xview" option} {fonts} { + .l xview 30 + .l xview scroll -1 pages + update + .l xview +} {0.44 0.64} +test listbox-3.122 {ListboxWidgetCmd procedure, "xview" option} {fonts} { + .l configure -width 1 + update + .l xview 30 + .l xview scroll -4 pages + update + .l xview +} {0.52 0.54} +test listbox-3.123 {ListboxWidgetCmd procedure, "yview" option} { + catch {destroy .l} + listbox .l + pack .l + update + .l yview +} {0 1} +test listbox-3.124 {ListboxWidgetCmd procedure, "yview" option} { + catch {destroy .l} + listbox .l + .l insert 0 el1 + pack .l + update + .l yview +} {0 1} +catch {destroy .l} +listbox .l -width 10 -height 5 -font $fixed +.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 +test listbox-3.125 {ListboxWidgetCmd procedure, "yview" option} { + .l yview 4 + update + .l yview +} {0.2 0.45} +test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last line} { + mkPartial + .partial.l yview +} {0 0.266667} +test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} { + list [catch {.l yview foo} msg] $msg +} {1 {bad listbox index "foo": must be active, anchor, end, @x,y, or a number}} +test listbox-3.128 {ListboxWidgetCmd procedure, "xview" option} { + list [catch {.l yview foo a b} msg] $msg +} {1 {unknown option "foo": must be moveto or scroll}} +test listbox-3.129 {ListboxWidgetCmd procedure, "xview" option} { + .l yview 0 + .l yview moveto .31 + .l yview +} {0.3 0.55} +test listbox-3.130 {ListboxWidgetCmd procedure, "xview" option} { + .l yview 2 + .l yview scroll 2 pages + .l yview +} {0.4 0.65} +test listbox-3.131 {ListboxWidgetCmd procedure, "xview" option} { + .l yview 10 + .l yview scroll -3 units + .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 +} {0.55 0.65} +test listbox-3.133 {ListboxWidgetCmd procedure, "xview" option} { + list [catch {.l whoknows} msg] $msg +} {1 {bad option "whoknows": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} +test listbox-3.134 {ListboxWidgetCmd procedure, "xview" option} { + list [catch {.l c} msg] $msg +} {1 {bad option "c": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} +test listbox-3.135 {ListboxWidgetCmd procedure, "xview" option} { + list [catch {.l in} msg] $msg +} {1 {bad option "in": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} +test listbox-3.136 {ListboxWidgetCmd procedure, "xview" option} { + list [catch {.l s} msg] $msg +} {1 {bad option "s": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} +test listbox-3.137 {ListboxWidgetCmd procedure, "xview" option} { + list [catch {.l se} msg] $msg +} {1 {bad option "se": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} + +# No tests for DestroyListbox: I can't come up with anything to test +# in this procedure. + +test listbox-4.1 {ConfigureListbox procedure} {fonts} { + catch {destroy .l} + listbox .l -setgrid 1 -width 25 -height 15 + pack .l + update + set x [getsize .] + .l configure -setgrid 0 + update + list $x [getsize .] +} {25x15 185x263} +resetGridInfo +test listbox-4.2 {ConfigureListbox procedure} { + .l configure -highlightthickness -3 + .l cget -highlightthickness +} {0} +test listbox-4.3 {ConfigureListbox procedure} { + .l configure -exportselection 0 + .l delete 0 end + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 + .l selection set 3 5 + .l configure -exportselection 1 + selection get +} {el3 +el4 +el5} +test listbox-4.4 {ConfigureListbox procedure} { + catch {destroy .e} + entry .e + .e insert 0 abc + .e select from 0 + .e select to 2 + .l configure -exportselection 0 + .l delete 0 end + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 + .l selection set 3 5 + .l selection clear 3 5 + .l configure -exportselection 1 + list [selection own] [selection get] +} {.e ab} +test listbox-4.5 {-exportselection option} { + selection clear . + .l configure -exportselection 1 + .l delete 0 end + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 + .l selection set 1 1 + set x {} + lappend x [catch {selection get} msg] $msg [.l curselection] + .l config -exportselection 0 + lappend x [catch {selection get} msg] $msg [.l curselection] + .l selection clear 0 end + lappend x [catch {selection get} msg] $msg [.l curselection] + .l selection set 1 3 + lappend x [catch {selection get} msg] $msg [.l curselection] + .l config -exportselection 1 + lappend x [catch {selection get} msg] $msg [.l curselection] +} {0 el1 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {1 2 3} 0 {el1 +el2 +el3} {1 2 3}} +test listbox-4.6 {ConfigureListbox procedure} {fonts} { + catch {destroy .l} + + # The following code (reset geometry, withdraw, etc.) is necessary + # to reset the state of some window managers like olvwm under + # SunOS 4.1.3. + + wm geom . 300x300 + update + wm geom . {} + wm withdraw . + listbox .l -font $fixed -width 15 -height 20 + pack .l + update + wm deiconify . + set x [getsize .] + .l configure -setgrid 1 + update + list $x [getsize .] +} {115x328 15x20} +test listbox-4.7 {ConfigureListbox procedure} { + catch {destroy .l} + wm withdraw . + listbox .l -font $fixed -width 30 -height 20 -setgrid 1 + wm geom . +0+0 + pack .l + update + wm deiconify . + set result [getsize .] + wm geom . 26x15 + update + lappend result [getsize .] + .l configure -setgrid 1 + update + lappend result [getsize .] +} {30x20 26x15 26x15} +wm geom . {} +catch {destroy .l} +resetGridInfo +test listbox-4.8 {ConfigureListbox procedure} { + catch {destroy .l} + listbox .l -width 15 -height 20 -xscrollcommand "record x" \ + -yscrollcommand "record y" + pack .l + update + .l configure -fg black + set log {} + update + set log +} {{y 0 1} {x 0 1}} + +# No tests for DisplayListbox: I don't know how to test this procedure. + +test listbox-5.1 {ListboxComputeGeometry procedure} {fonts} { + catch {destroy .l} + listbox .l -font $fixed -width 15 -height 20 + pack .l + list [winfo reqwidth .l] [winfo reqheight .l] +} {115 328} +test listbox-5.2 {ListboxComputeGeometry procedure} {fonts} { + catch {destroy .l} + listbox .l -font $fixed -width 0 -height 10 + pack .l + update + list [winfo reqwidth .l] [winfo reqheight .l] +} {17 168} +test listbox-5.3 {ListboxComputeGeometry procedure} {fonts} { + catch {destroy .l} + listbox .l -font $fixed -width 0 -height 10 -bd 3 + .l insert 0 Short "Really much longer" Longer + pack .l + update + list [winfo reqwidth .l] [winfo reqheight .l] +} {138 170} +test listbox-5.4 {ListboxComputeGeometry procedure} {fonts} { + catch {destroy .l} + listbox .l -font $fixed -width 10 -height 0 + pack .l + update + list [winfo reqwidth .l] [winfo reqheight .l] +} {80 24} +test listbox-5.5 {ListboxComputeGeometry procedure} {fonts} { + catch {destroy .l} + listbox .l -font $fixed -width 10 -height 0 -highlightthickness 0 + .l insert 0 Short "Really much longer" Longer + pack .l + update + list [winfo reqwidth .l] [winfo reqheight .l] +} {76 52} +test listbox-5.6 {ListboxComputeGeometry procedure} { + # If "0" in selected font had 0 width, caused divide-by-zero error. + + catch {destroy .l} + pack [listbox .l -font {{open look glyph}}] + update +} {} + + +catch {destroy .l} +listbox .l -height 2 -xscrollcommand "record x" -yscrollcommand "record y" +pack .l +update +test listbox-6.1 {InsertEls procedure} { + .l delete 0 end + .l insert end a b c d + .l insert 5 x y z + .l insert 2 A + .l insert 0 q r s + .l get 0 end +} {q r s a b A c d x y z} +test listbox-6.2 {InsertEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l selection anchor 2 + .l insert 2 A B + .l index anchor +} {4} +test listbox-6.3 {InsertEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l selection anchor 2 + .l insert 3 A B + .l index anchor +} {2} +test listbox-6.4 {InsertEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l yview 3 + update + .l insert 2 A B + .l index @0,0 +} {5} +test listbox-6.5 {InsertEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l yview 3 + update + .l insert 3 A B + .l index @0,0 +} {3} +test listbox-6.6 {InsertEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l activate 5 + .l insert 5 A B + .l index active +} {7} +test listbox-6.7 {InsertEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l activate 5 + .l insert 6 A B + .l index active +} {5} +test listbox-6.8 {InsertEls procedure} { + .l delete 0 end + .l insert 0 a b c + .l index active +} {2} +test listbox-6.9 {InsertEls procedure} { + .l delete 0 end + .l insert 0 + .l index active +} {0} +test listbox-6.10 {InsertEls procedure} { + .l delete 0 end + .l insert 0 a b "two words" c d e f g h i j + update + set log {} + .l insert 0 word + update + set log +} {{y 0 0.166667}} +test listbox-6.11 {InsertEls procedure} { + .l delete 0 end + .l insert 0 a b "two words" c d e f g h i j + update + set log {} + .l insert 0 "much longer entry" + update + set log +} {{y 0 0.166667} {x 0 1}} +test listbox-6.12 {InsertEls procedure} {fonts} { + catch {destroy .l2} + listbox .l2 -width 0 -height 0 + pack .l2 -side top + .l2 insert 0 a b "two words" c d + set x {} + lappend x [winfo reqwidth .l2] [winfo reqheight .l2] + .l2 insert 0 "much longer entry" + lappend x [winfo reqwidth .l2] [winfo reqheight .l2] +} {80 93 122 110} + +test listbox-7.1 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l selection set 1 6 + .l delete 4 3 + list [.l size] [selection get] +} {10 {b +c +d +e +f +g}} +test listbox-7.2 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l selection set 3 6 + .l delete 4 4 + list [.l size] [.l get 4] [.l curselection] +} {9 f {3 4 5}} +test listbox-7.3 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l delete 0 3 + list [.l size] [.l get 0] [.l get 1] +} {6 e f} +test listbox-7.4 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l delete 8 1000 + list [.l size] [.l get 7] +} {8 h} +test listbox-7.5 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l selection anchor 2 + .l delete 0 1 + .l index anchor +} {0} +test listbox-7.6 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l selection anchor 2 + .l delete 2 + .l index anchor +} {2} +test listbox-7.7 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l selection anchor 4 + .l delete 2 5 + .l index anchor +} {2} +test listbox-7.8 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l selection anchor 3 + .l delete 4 5 + .l index anchor +} {3} +test listbox-7.9 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l yview 3 + update + .l delete 1 2 + .l index @0,0 +} {1} +test listbox-7.10 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l yview 3 + update + .l delete 3 4 + .l index @0,0 +} {3} +test listbox-7.11 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l yview 3 + update + .l delete 4 6 + .l index @0,0 +} {3} +test listbox-7.12 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l yview 3 + update + .l delete 3 end + .l index @0,0 +} {1} +test listbox-7.13 {DeleteEls procedure, updating view with partial last line} { + mkPartial + .partial.l yview 8 + update + .partial.l delete 10 13 + .partial.l index @0,0 +} {7} +test listbox-7.14 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l activate 6 + .l delete 3 4 + .l index active +} {4} +test listbox-7.15 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l activate 6 + .l delete 5 7 + .l index active +} {5} +test listbox-7.16 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l activate 6 + .l delete 5 end + .l index active +} {4} +test listbox-7.17 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j + .l activate 6 + .l delete 0 end + .l index active +} {0} +test listbox-7.18 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c "two words" d e f g h i j + update + set log {} + .l delete 4 6 + update + set log +} {{y 0 0.25}} +test listbox-7.19 {DeleteEls procedure} { + .l delete 0 end + .l insert 0 a b c "two words" d e f g h i j + update + set log {} + .l delete 3 + update + set log +} {{y 0 0.2} {x 0 1}} +test listbox-7.20 {DeleteEls procedure} {fonts} { + catch {destroy .l2} + listbox .l2 -width 0 -height 0 + pack .l2 -side top + .l2 insert 0 a b "two words" c d e f g + set x {} + lappend x [winfo reqwidth .l2] [winfo reqheight .l2] + .l2 delete 2 4 + lappend x [winfo reqwidth .l2] [winfo reqheight .l2] +} {80 144 17 93} +catch {destroy .l2} + +test listbox-8.1 {ListboxEventProc procedure} {fonts} { + catch {destroy .l} + listbox .l -setgrid 1 + pack .l + update + set x [getsize .] + destroy .l + list $x [getsize .] [winfo exists .l] [info command .l] +} {20x10 150x178 0 {}} +resetGridInfo +test listbox-8.2 {ListboxEventProc procedure} {fonts} { + catch {destroy .l} + listbox .l -height 5 -width 10 + .l insert 0 a b c "A string that is very very long" d e f g h i j k + pack .l + update + place .l -width 50 -height 80 + update + list [.l xview] [.l yview] +} {{0 0.222222} {0 0.333333}} +test listbox-8.3 {ListboxEventProc procedure} { + eval destroy [winfo children .] + listbox .l1 -bg #543210 + rename .l1 .l2 + set x {} + lappend x [winfo children .] + lappend x [.l2 cget -bg] + destroy .l1 + lappend x [info command .l*] [winfo children .] +} {.l1 #543210 {} {}} + +test listbox-9.1 {ListboxCmdDeletedProc procedure} { + eval destroy [winfo children .] + listbox .l1 + rename .l1 {} + list [info command .l*] [winfo children .] +} {{} {}} +test listbox-9.2 {ListboxCmdDeletedProc procedure, disabling -setgrid} fonts { + catch {destroy .top} + toplevel .top + wm geom .top +0+0 + listbox .top.l -setgrid 1 -width 20 -height 10 + pack .top.l + update + set x [wm geometry .top] + rename .top.l {} + update + lappend x [wm geometry .top] + destroy .top + set x +} {20x10+0+0 150x178+0+0} + +catch {destroy .l} +listbox .l +pack .l +.l delete 0 end +.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 +test listbox-10.1 {GetListboxIndex procedure} { + .l activate 3 + list [.l activate 3; .l index active] [.l activate 6; .l index active] +} {3 6} +test listbox-10.2 {GetListboxIndex procedure} { + .l selection anchor 2 + .l index anchor +} 2 +test listbox-10.3 {GetListboxIndex procedure} { + .l insert end A B C D E + .l selection anchor end + .l delete 12 end + list [.l index anchor] [.l index end] +} {12 12} +test listbox-10.4 {GetListboxIndex procedure} { + list [catch {.l index a} msg] $msg +} {1 {bad listbox index "a": must be active, anchor, end, @x,y, or a number}} +test listbox-10.5 {GetListboxIndex procedure} { + .l index end +} {12} +test listbox-10.6 {GetListboxIndex procedure} { + .l get end +} {el11} +test listbox-10.7 {GetListboxIndex procedure} { + .l delete 0 end + .l index end +} 0 +.l delete 0 end +.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 +update +test listbox-10.8 {GetListboxIndex procedure} { + list [catch {.l index @} msg] $msg +} {1 {bad listbox index "@": must be active, anchor, end, @x,y, or a number}} +test listbox-10.9 {GetListboxIndex procedure} { + list [catch {.l index @foo} msg] $msg +} {1 {bad listbox index "@foo": must be active, anchor, end, @x,y, or a number}} +test listbox-10.10 {GetListboxIndex procedure} { + list [catch {.l index @1x3} msg] $msg +} {1 {bad listbox index "@1x3": must be active, anchor, end, @x,y, or a number}} +test listbox-10.11 {GetListboxIndex procedure} { + list [catch {.l index @1,} msg] $msg +} {1 {bad listbox index "@1,": must be active, anchor, end, @x,y, or a number}} +test listbox-10.12 {GetListboxIndex procedure} { + list [catch {.l index @1,foo} msg] $msg +} {1 {bad listbox index "@1,foo": must be active, anchor, end, @x,y, or a number}} +test listbox-10.13 {GetListboxIndex procedure} { + list [catch {.l index @1,2x} msg] $msg +} {1 {bad listbox index "@1,2x": must be active, anchor, end, @x,y, or a number}} +test listbox-10.14 {GetListboxIndex procedure} {fonts} { + list [.l index @5,57] [.l index @5,58] +} {3 3} +test listbox-10.15 {GetListboxIndex procedure} { + list [catch {.l index 1xy} msg] $msg +} {1 {bad listbox index "1xy": must be active, anchor, end, @x,y, or a number}} +test listbox-10.16 {GetListboxIndex procedure} { + .l index 3 +} {3} +test listbox-10.17 {GetListboxIndex procedure} { + .l index 20 +} {20} +test listbox-10.18 {GetListboxIndex procedure} { + .l get 20 +} {} +test listbox-10.19 {GetListboxIndex procedure} { + .l index -2 +} -2 +test listbox-10.20 {GetListboxIndex procedure} { + .l delete 0 end + .l index 1 +} 1 + +test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} { + catch {destroy .l} + listbox .l -height 5 + pack .l + .l insert 0 a b c d e f g h i j + .l yview 3 + update + set x [.l index @0,0] + .l yview -1 + update + lappend x [.l index @0,0] +} {3 0} +test listbox-11.2 {ChangeListboxView procedure, boundary conditions for index} { + catch {destroy .l} + listbox .l -height 5 + pack .l + .l insert 0 a b c d e f g h i j + .l yview 3 + update + set x [.l index @0,0] + .l yview 20 + update + lappend x [.l index @0,0] +} {3 5} +test listbox-11.3 {ChangeListboxView procedure} { + catch {destroy .l} + listbox .l -height 5 -yscrollcommand "record y" + pack .l + .l insert 0 a b c d e f g h i j + update + set log {} + .l yview 2 + update + list [.l yview] $log +} {{0.2 0.7} {{y 0.2 0.7}}} +test listbox-11.4 {ChangeListboxView procedure} { + catch {destroy .l} + listbox .l -height 5 -yscrollcommand "record y" + pack .l + .l insert 0 a b c d e f g h i j + update + set log {} + .l yview 8 + update + list [.l yview] $log +} {{0.5 1} {{y 0.5 1}}} +test listbox-11.5 {ChangeListboxView procedure} { + catch {destroy .l} + listbox .l -height 5 -yscrollcommand "record y" + pack .l + .l insert 0 a b c d e f g h i j + .l yview 3 + update + set log {} + .l yview 3 + update + list [.l yview] $log +} {{0.3 0.8} {}} +test listbox-11.6 {ChangeListboxView procedure, partial last line} { + mkPartial + .partial.l yview 13 + .partial.l index @0,0 +} {11} + +catch {destroy .l} +listbox .l -font $fixed -xscrollcommand "record x" -width 10 +.l insert 0 0123456789a123456789b123456789c123456789d123456789e123456789f123456789g123456789h123456789i123456789 +pack .l +update +test listbox-12.1 {ChangeListboxOffset procedure} {fonts} { + set log {} + .l xview 99 + update + list [.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 +} {{0 0.1} {{x 0 0.1}}} +test listbox-12.3 {ChangeListboxOffset procedure} {fonts} { + .l xview 10 + update + set log {} + .l xview 10 + update + list [.l xview] $log +} {{0.1 0.2} {}} + +catch {destroy .l} +listbox .l -font $fixed -width 10 -height 5 +pack .l +.l insert 0 a bb c d e f g h i j k l m n o p q r s +.l insert 0 0123456789a123456789b123456789c123456789d123456789 +update +set width [expr [lindex [.l bbox 2] 2] - [lindex [.l bbox 1] 2]] +set height [expr [lindex [.l bbox 2] 1] - [lindex [.l bbox 1] 1]] +test listbox-13.1 {ListboxScanTo procedure} {fonts} { + .l yview 0 + .l xview 0 + .l scan mark 10 20 + .l scan dragto [expr 10-$width] [expr 20-$height] + update + list [.l xview] [.l yview] +} {{0.2 0.4} {0.5 0.75}} +test listbox-13.2 {ListboxScanTo procedure} {fonts} { + .l yview 5 + .l xview 10 + .l scan mark 10 20 + .l scan dragto 20 40 + update + set x [list [.l xview] [.l yview]] + .l scan dragto [expr 20-$width] [expr 40-$height] + update + lappend x [.l xview] [.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 + .l xview moveto 1.0 + .l scan mark 10 20 + .l scan dragto 5 10 + update + set x [list [.l xview] [.l yview]] + .l scan dragto [expr 5+$width] [expr 10+$height] + update + lappend x [.l xview] [.l yview] +} {{0.8 1} {0.75 1} {0.62 0.82} {0.25 0.5}} + +test listbox-14.1 {NearestListboxElement procedure, partial last line} { + mkPartial + .partial.l nearest [winfo height .partial.l] +} {4} +catch {destroy .l} +listbox .l -font $fixed -width 20 -height 10 +.l insert 0 a b c d e f g h i j k l m n o p q r s t +.l yview 4 +pack .l +update +test listbox-14.2 {NearestListboxElement procedure} {fonts} { + .l index @50,0 +} {4} +test listbox-14.3 {NearestListboxElement procedure} {fonts} { + list [.l index @50,35] [.l index @50,36] +} {5 6} +test listbox-14.4 {NearestListboxElement procedure} {fonts} { + .l index @50,200 +} {13} + +test listbox-15.1 {ListboxSelect procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j k l m n o p + .l select set 2 4 + .l select set 7 12 + .l select clear 4 7 + .l curselection +} {2 3 8 9 10 11 12} +test listbox-15.2 {ListboxSelect procedure} { + .l delete 0 end + .l insert 0 a b c d e f g h i j k l m n o p + catch {destroy .e} + entry .e + .e insert 0 "This is some text" + .e select from 0 + .e select to 7 + .l selection clear 2 4 + set x [selection own] + .l selection set 3 + list $x [selection own] [selection get] +} {.e .l d} +test listbox-15.3 {ListboxSelect procedure} { + .l delete 0 end + .l selection clear 0 end + .l select set 0 end + .l curselection +} {} +test listbox-15.4 {ListboxSelect procedure, boundary conditions for indices} { + .l delete 0 end + .l insert 0 a b c d e f + .l select clear 0 end + .l select set -2 -1 + .l curselection +} {} +test listbox-15.5 {ListboxSelect procedure, boundary conditions for indices} { + .l delete 0 end + .l insert 0 a b c d e f + .l select clear 0 end + .l select set -1 3 + .l curselection +} {0 1 2 3} +test listbox-15.6 {ListboxSelect procedure, boundary conditions for indices} { + .l delete 0 end + .l insert 0 a b c d e f + .l select clear 0 end + .l select set 2 4 + .l curselection +} {2 3 4} +test listbox-15.7 {ListboxSelect procedure, boundary conditions for indices} { + .l delete 0 end + .l insert 0 a b c d e f + .l select clear 0 end + .l select set 4 end + .l curselection +} {4 5} +test listbox-15.8 {ListboxSelect procedure, boundary conditions for indices} { + .l delete 0 end + .l insert 0 a b c d e f + .l select clear 0 end + .l select set 4 30 + .l curselection +} {4 5} +test listbox-15.9 {ListboxSelect procedure, boundary conditions for indices} { + .l delete 0 end + .l insert 0 a b c d e f + .l select clear 0 end + .l select set end 30 + .l curselection +} {5} +test listbox-15.10 {ListboxSelect procedure, boundary conditions for indices} { + .l delete 0 end + .l insert 0 a b c d e f + .l select clear 0 end + .l select set 20 25 + .l curselection +} {} + +test listbox-16.1 {ListboxFetchSelection procedure} { + .l delete 0 end + .l insert 0 a b c "two words" e f g h i \\ k l m n o p + .l selection set 2 4 + .l selection set 9 + .l selection set 11 12 + selection get +} "c\ntwo words\ne\n\\\nl\nm" +test listbox-16.2 {ListboxFetchSelection procedure} { + .l delete 0 end + .l insert 0 a b c "two words" e f g h i \\ k l m n o p + .l selection set 3 + selection get +} "two words" +test listbox-16.3 {ListboxFetchSelection procedure, retrieve in several parts} { + set long "This is quite a long string\n" + append long $long $long $long $long + append long $long $long $long $long + append long $long $long + .l delete 0 end + .l insert 0 1$long 2$long 3$long 4$long 5$long + .l selection set 0 end + set sel [selection get] + string compare 1$long\n2$long\n3$long\n4$long\n5$long $sel +} {0} +catch {unset long sel} + +test listbox-17.1 {ListboxLostSelection procedure} { + .l delete 0 end + .l insert 0 a b c d e + .l select set 0 end + catch {destroy .e} + entry .e + .e insert 0 "This is some text" + .e select from 0 + .e select to 5 + .l curselection +} {} +test listbox-17.2 {ListboxLostSelection procedure} { + .l delete 0 end + .l insert 0 a b c d e + .l select set 0 end + .l configure -exportselection 0 + catch {destroy .e} + entry .e + .e insert 0 "This is some text" + .e select from 0 + .e select to 5 + .l curselection +} {0 1 2 3 4} + +catch {destroy .l} +listbox .l -font $fixed -width 10 -height 5 +pack .l +update +test listbox-18.1 {ListboxUpdateVScrollbar procedure} { + .l configure -yscrollcommand "record y" + set log {} + .l insert 0 a b c + update + .l insert end d e f g h + update + .l delete 0 end + update + set log +} {{y 0 1} {y 0 0.625} {y 0 1}} +test listbox-18.2 {ListboxUpdateVScrollbar procedure, partial last line} { + mkPartial + .partial.l configure -yscrollcommand "record y" + set log {} + .partial.l yview 3 + update + set log +} {{y 0.2 0.466667}} +test listbox-18.3 {ListboxUpdateVScrollbar procedure} { + proc bgerror args { + global x errorInfo + set x [list $args $errorInfo] + } + .l configure -yscrollcommand gorp + .l insert 0 foo + update + set x +} {{{invalid command name "gorp"}} {invalid command name "gorp" + while executing +"gorp 0 1" + (vertical scrolling command executed by listbox)}} +if {[info exists bgerror]} { + rename bgerror {} +} + +catch {destroy .l} +listbox .l -font $fixed -width 10 -height 5 +pack .l +update +test listbox-19.1 {ListboxUpdateVScrollbar procedure} {fonts} { + .l configure -xscrollcommand "record x" + set log {} + .l insert 0 abc + update + .l insert 0 "This is a much longer string..." + update + .l delete 0 end + update + set log +} {{x 0 1} {x 0 0.322581} {x 0 1}} +test listbox-19.2 {ListboxUpdateVScrollbar procedure} { + proc bgerror args { + global x errorInfo + set x [list $args $errorInfo] + } + .l configure -xscrollcommand bogus + .l insert 0 foo + update + set x +} {{{invalid command name "bogus"}} {invalid command name "bogus" + while executing +"bogus 0 1" + (horizontal scrolling command executed by listbox)}} + +set l [interp hidden] +eval destroy [winfo children .] + +test listbox-20.1 {listbox vs hidden commands} { + catch {destroy .l} + listbox .l + interp hide {} .l + destroy .l + list [winfo children .] [interp hidden] +} [list {} $l] + +resetGridInfo +catch {destroy .l2} +catch {destroy .t} +catch {destroy .e} +catch {destroy .partial} +option clear + diff --git a/tests/macEmbed.test b/tests/macEmbed.test new file mode 100644 index 0000000..f912dcd --- /dev/null +++ b/tests/macEmbed.test @@ -0,0 +1,290 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) macEmbed.test 1.1 97/08/06 21:18:53 + +if {$tcl_platform(platform) != "macintosh"} { + return +} + +if {[info procs test] != "test"} { + source defs +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + + +test macEmbed-1.1 {TkpUseWindow procedure, bad window identifier} { + 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} { + 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} { + eval destroy [winfo child .] + 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} { + eval destroy [winfo child .] + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} {tempNotMac} { + catch {interp delete child} + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} + + + +foreach w [winfo child .] { + catch {destroy $w} +} diff --git a/tests/macFont.test b/tests/macFont.test new file mode 100644 index 0000000..aa342a6 --- /dev/null +++ b/tests/macFont.test @@ -0,0 +1,182 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) macFont.test 1.5 97/05/05 14:21:05 + +if {$tcl_platform(platform)!="macintosh"} { + return +} + +if {[string compare test [info procs test]] != 0} { + source defs +} + +catch {destroy .b} +toplevel .b +update idletasks + +set courier {Courier 10} +set cx [font measure $courier 0] + +label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Monaco 9" +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]" +} + +test macfont-1.1 {TkpGetNativeFont procedure: not native} { + list [catch {font measure {} xyz} msg] $msg +} {1 {font "" doesn't exist}} +test macfont-1.2 {TkpGetNativeFont procedure: native} { + font measure system "0" + font measure application "0" + set x {} +} {} + +test macfont-2.1 {TkpGetFontFromAttributes procedure: no family} { + font actual {-underline 1} -family +} [font actual system -family] +test macfont-2.2 {TkpGetFontFromAttributes procedure: long family name} { + set x "12345678901234567890123456789012345678901234567890" + set x "$x$x$x$x$x$x" + font actual "-family $x" -family +} [font actual system -family] +test macfont-2.3 {TkpGetFontFromAttributes procedure: family} { + font actual {-family Courier} -family +} {Courier} +test macfont-2.4 {TkpGetFontFromAttributes procedure: Times fonts} { + set x {} + lappend x [font actual {-family "Times"} -family] + lappend x [font actual {-family "Times New Roman"} -family] +} {Times Times} +test macfont-2.5 {TkpGetFontFromAttributes procedure: Courier fonts} { + set x {} + lappend x [font actual {-family "Courier"} -family] + lappend x [font actual {-family "Courier New"} -family] +} {Courier Courier} +test macfont-2.6 {TkpGetFontFromAttributes procedure: Helvetica fonts} { + 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-2.7 {TkpGetFontFromAttributes procedure: styles} { + font actual {-weight normal} -weight +} {normal} +test macfont-2.8 {TkpGetFontFromAttributes procedure: styles} { + font actual {-weight bold} -weight +} {bold} +test macfont-2.9 {TkpGetFontFromAttributes procedure: styles} { + font actual {-slant roman} -slant +} {roman} +test macfont-2.10 {TkpGetFontFromAttributes procedure: styles} { + font actual {-slant italic} -slant +} {italic} +test macfont-2.11 {TkpGetFontFromAttributes procedure: styles} { + font actual {-underline false} -underline +} {0} +test macfont-2.12 {TkpGetFontFromAttributes procedure: styles} { + font actual {-underline true} -underline +} {1} +test macfont-2.13 {TkpGetFontFromAttributes procedure: styles} { + font actual {-overstrike false} -overstrike +} {0} +test macfont-2.14 {TkpGetFontFromAttributes procedure: styles} { + font actual {-overstrike true} -overstrike +} {0} + +test macfont-3.1 {TkpDeleteFont procedure} { + font actual {-family xyz} + set x {} +} {} + +test macfont-4.1 {TkpGetFontFamilies procedure} { + font families + set x {} +} {} + +test macfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} { + .b.l config -wrap 0 -text "000000" + getsize +} "[expr $ax*6] $ay" +test macfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} { + .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" + getsize +} "[expr $ax*256] $ay" +test macfont-5.3 {Tk_MeasureChars procedure: all chars did fit} { + .b.l config -wrap [expr $ax*10] -text "00000000" + getsize +} "[expr $ax*8] $ay" +test macfont-5.4 {Tk_MeasureChars procedure: not all chars fit} { + .b.l config -wrap [expr $ax*6] -text "00000000" + getsize +} "[expr $ax*6] [expr $ay*2]" +test macfont-5.5 {Tk_MeasureChars procedure: already saw space in line} { + .b.l config -wrap [expr $ax*12] -text "000000 0000000" + getsize +} "[expr $ax*7] [expr $ay*2]" +test macfont-5.6 {Tk_MeasureChars procedure: internal spaces significant} { + .b.l config -wrap [expr $ax*12] -text "000 00 00000" + getsize +} "[expr $ax*7] [expr $ay*2]" +test macfont-5.7 {Tk_MeasureChars procedure: include last partial char} { + .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-5.8 {Tk_MeasureChars procedure: at least one char on line} { + .b.l config -text "000000" -wrap 1 + getsize +} "$ax [expr $ay*6]" +test macfont-5.9 {Tk_MeasureChars procedure: whole words} { + .b.l config -wrap [expr $ax*8] -text "000000 0000" + getsize +} "[expr $ax*6] [expr $ay*2]" +test macfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} { + .b.l config -wrap [expr $ax*12] -text "0000000000000000" + getsize +} "[expr $ax*12] [expr $ay*2]" + +test macfont-6.1 {Tk_DrawChars procedure} { + .b.l config -text "a" + update +} {} + +test macfont-7.1 {AllocMacFont procedure: use old font} { + font create xyz + button .c -font xyz + font configure xyz -family times + update + destroy .c + font delete xyz +} {} +test macfont-7.2 {AllocMacFont procedure: extract info from style} { + font actual {Monaco 9 bold italic underline overstrike} +} {-family Monaco -size 9 -weight bold -slant italic -underline 1 -overstrike 0} +test macfont-7.3 {AllocMacFont procedure: extract text metrics} { + font metric {Geneva 10} -fixed +} {0} +test macfont-7.4 {AllocMacFont procedure: extract text metrics} { + font metric "Monaco 9" -fixed +} {1} + +destroy .b diff --git a/tests/macMenu.test b/tests/macMenu.test new file mode 100644 index 0000000..2c10e86 --- /dev/null +++ b/tests/macMenu.test @@ -0,0 +1,1565 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) macMenu.test 1.23 97/07/10 13:35:52 + +if {$tcl_platform(platform) != "macintosh"} { + return +} + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +proc deleteWindows {} { + foreach i [winfo children .] { + catch [destroy $i] + } +} + +deleteWindows +wm geometry . {} +raise . + +test macMenu-1.0 {TkMacUseMenuID} {} { + # Can't really test TkMacUseMenuID; it's only called on startup. +} {} + +test macMenu-2.1 {GetNewID} { + catch {destroy .m1} + list [catch {menu .m1} msg] $msg [destroy .m1] +} {0 .m1 {}} +test macMenu-2.2 {GetNewID - cascade menu} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test macMenu-5.2 {TkpDestroyMenu - help menu} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add command -label test + update idletasks + list [catch {destroy .m1} msg] $msg +} {0 {}} + +test macMenu-6.1 {SetMenuCascade} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + list [catch {menu .m1} msg] $msg [destroy .m1] +} {0 .m1 {}} +test macMenu-8.2 {GetEntryText} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -bitmap questhead} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-8.4 {GetEntryText} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-8.5 {GetEntryText} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -label foo} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-10.3 {SetMenuIndicator - indiatorOn false} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add checkbutton -label foo} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-10.5 {SetMenuIndicator - checkbutton} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -accel "Control+S"} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-12.5 {TkpConfigureMenuEntry - Ctrl} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -accel "Ctrl+S"} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-12.6 {TkpConfigureMenuEntry - Shift} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -accel "Shift+S"} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-12.7 {TkpConfigureMenuEntry - Option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -accel "Opt+S"} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-12.8 {TkpConfigureMenuEntry - Command} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -accel "Command+S"} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-12.9 {TkpConfigureMenuEntry - Cmd} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -accel "Cmd+S"} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-12.10 {TkpConfigureMenuEntry - Alt} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -accel "Alt+S"} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-12.11 {TkpConfigureMenuEntry - Meta} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add separator + list [catch {update idletasks} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-13.5 {ReconfigureIndividualMenu - disabled} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 -postcommand "destroy .m1" + list [catch {.m1 post 40 40} msg] $msg +} {0 {}} +test macMenu-16.2 {TkpPostMenu} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -label test} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-17.2 {TkpMenuNewEntry - idle pending} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + . configure -menu .m1 + raise . + list [catch {update} msg] $msg [. configure -menu ""] +} {0 {} {}} +test macMenu-18.5 {DrawMenuBarWhenIdle - menu there} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + . configure -menu "" + raise . + list [catch {update} msg] $msg +} {0 {}} + +test macMenu-21.1 {TkpSetMainMenubar - not front window} { + 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} { + . configure -menu "" + raise . + list [catch {update} msg] $msg +} {0 {}} +test macMenu-21.3 {TkpSetMainMenubar - different interps} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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 + tkTearOffMenu .t2.m1.foo 100 100 + list [catch {update} msg] $msg [destroy .t2] +} {0 {} {}} + +test macMenu-22.1 {TkSetWindowMenuBar} { +} {} + +test macMenu-23.1 {TkMacDispatchMenuEvent} { + # needs to be interactive. +} {} + +test macMenu-24.1 {GetMenuIndicatorGeometry} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +test macMenu-25.1 {GetMenuAccelGeometry - cascade entry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test macMenu-25.2 {GetMenuAccelGeometry - no accel} { + catch {destroy .m1} + menu .m1 + .m1 add command + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test macMenu-25.3 {GetMenuAccelGeometry - no special chars - arbitrary string} { + catch {destroy .m1} + menu .m1 + .m1 add command -accel "Test" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test macMenu-25.4 {GetMenuAccelGeometry - Command} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Cmd+S" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test macMenu-25.5 {GetMenuAccelGeometry - Control} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Ctrl+S" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test macMenu-25.6 {GetMenuAccelGeometry - Shift} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Shift+S" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test macMenu-25.7 {GetMenuAccelGeometry - Option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Opt+S" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test macMenu-25.8 {GetMenuAccelGeometry - Combination} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Cmd+Shift+S" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test macMenu-25.9 {GetMenuAccelGeometry - extra text} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Command+Delete" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +test macMenu-26.1 {GetTearoffEntryGeometry} { + # can't call this on power mac. +} {} + +test macMenu-27.1 {GetMenuSeparatorGeometry} { + catch {destroy .m1} + menu .m1 + .m1 add separator + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +test macMenu-28.1 {DrawMenuEntryIndicator - non-checkbutton} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-28.2 {DrawMenuEntryIndicator - indicator off} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo -indicatoron 0 + .m1 invoke foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-28.3 {DrawMenuEntryIndicator - not selected} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-28.4 {DrawMenuEntryIndicator - checkbutton} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-28.5 {DrawMenuEntryIndicator - radiobutton} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -label foo + .m1 invoke foo + set tearoff [tkTearOffMenu .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} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Cmd+S" + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +# Cannot reproduce resources missing +test macMenu-30.1 {DrawMenuEntryAccelerator - cascade entry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-30.2 {DrawMenuEntryAccelerator - no accel string} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-30.3 {DrawMenuEntryAccelerator - random accel string} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-30.4 {DrawMenuEntryAccelerator - Command} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Cmd+S" + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-30.5 {DrawMenuEntryAccelerator - Option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Opt+S" + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-30.6 {DrawMenuEntryAccelerator - Shift} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Shift+S" + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-30.7 {DrawMenuEntryAccelerator - Control} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Ctrl+S" + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test macMenu-30.8 {DrawMenuEntryAccelerator - combination} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Cmd+Shift+S" + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +test macMenu-31.1 {DrawMenuSeparator} { + catch {destroy .m1} + menu .m1 + .m1 add separator + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +test macMenu-32.1 {TkpDrawMenuEntryLabel} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .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} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .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} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -activeforeground red + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.3 {TkpDrawMenuEntry - gc for active and strict motif} { + catch {destroy .m1} + menu .m1 + set tk_strictMotif 1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .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} { + catch {destroy .m1} + menu .m1 -disabledforeground blue + .m1 add command -label foo -state disabled -background red + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} { + catch {destroy .m1} + menu .m1 -disabledforeground blue + .m1 add command -label foo -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} { + catch {destroy .m1} + menu .m1 -disabledforeground "" + .m1 add command -label foo -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.7 {TkpDrawMenuEntry - gc for normal - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -foreground red + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.8 {TkpDrawMenuEntry - gc for normal} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.9 {TkpDrawMenuEntry - gc for indicator - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo -selectcolor orange + .m1 invoke 1 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.10 {TkpDrawMenuEntry - gc for indicator} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke 1 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.11 {TkpDrawMenuEntry - border - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -activebackground green + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.12 {TkpDrawMenuEntry - border} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.13 {TkpDrawMenuEntry - active border - strict motif} { + catch {destroy .m1} + set tk_strictMotif 1 + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .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} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -activeforeground yellow + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.15 {TkpDrawMenuEntry - active border} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.16 {TkpDrawMenuEntry - font - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -font "Helvectica 72" + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.17 {TkpDrawMenuEntry - font} { + catch {destroy .m1} + menu .m1 -font "Courier 72" + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.18 {TkpDrawMenuEntry - separator} { + catch {destroy .m1} + menu .m1 + .m1 add separator + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.19 {TkpDrawMenuEntry - standard} { + catch {destroy .mb} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.20 {TkpDrawMenuEntry - disabled cascade item} { + 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 [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.21 {TkpDrawMenuEntry - indicator} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label macMenu-40.20 + .m1 invoke 0 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-40.22 {TkpDrawMenuEntry - indicator - hideMargin} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label macMenu-40.21 -hidemargin 1 + .m1 invoke 0 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} + +test macMenu-41.1 {TkpComputeStandardMenuGeometry - no entries} { + catch {destroy .m1} + menu .m1 + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-41.2 {TkpComputeStandardMenuGeometry - one entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "one" + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-41.3 {TkpComputeStandardMenuGeometry - more than one entry} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add separator + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-41.5 {TkpComputeStandardMenuGeometry - standard label geometry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-41.6 {TkpComputeStandardMenuGeometry - different font for entry} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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 } { + 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} { + 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} { + catch {destroy .m1} + menu .m1 -tearoff 0 + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-41.16 {TkpComputeStandardMenuGeometry - first column bigger} { + 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} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + set tearoff [tkTearOffMenu .m1] + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-42.2 {DrawMenuEntryLabel - drawing image} { + catch {destroy .m1} + catch {image delete image1} + image create test image1 + menu .m1 + .m1 add command -image image1 + set tearoff [tkTearOffMenu .m1] + list [update idletasks] [destroy .m1] [image delete image1] +} {{} {} {}} +test macMenu-42.3 {DrawMenuEntryLabel - drawing select image} { + 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 [tkTearOffMenu .m1] + list [update idletasks] [destroy .m1] [eval image delete [image names]] +} {{} {} {}} +test macMenu-42.4 {DrawMenuEntryLabel - drawing a bitmap} { + catch {destroy .m1} + menu .m1 + .m1 add command -bitmap questhead + set tearoff [tkTearOffMenu .m1] + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-42.5 {DrawMenuEntryLabel - drawing null label} { + catch {destroy .m1} + menu .m1 + .m1 add command + set tearoff [tkTearOffMenu .m1] + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-42.6 {DrawMenuEntryLabel - drawing real label} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "This is a long label" -underline 3 + set tearoff [tkTearOffMenu .m1] + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-42.7 {DrawMenuEntryLabel - drawing disabled label} { + catch {destroy .m1} + menu .m1 -disabledforeground "" + .m1 add command -label "This is a long label" -state disabled + set tearoff [tkTearOffMenu .m1] + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-42.8 {DrawMenuEntryLabel - disabled images} { + catch {destroy .m1} + catch {image delete image1} + image create test image1 + menu .m1 + .m1 add command -image image1 -state disabled + set tearoff [tkTearOffMenu .m1 100 100] + list [update idletasks] [destroy .m1] [image delete image1] +} {{} {} {}} + +test macMenu-43.1 {GetMenuLabelGeometry - image} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add command -bitmap questhead + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-43.3 {GetMenuLabelGeometry - no text} { + catch {destroy .m1} + menu .m1 + .m1 add command + list [update idletasks] [destroy .m1] +} {{} {}} +test macMenu-43.4 {GetMenuLabelGeometry - text} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "This is a test." + list [update idletasks] [destroy .m1] +} {{} {}} + +test macMenu-44.1 {DrawMenuEntryBackground} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test macMenu-44.2 {DrawMenuEntryBackground} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + $tearoff activate 0 + list [update] [destroy .m1] +} {{} {}} + +test macMenu-45.1 {TkpMenuInit - called at boot time} {} {} + +deleteWindows + diff --git a/tests/macWinMenu.test b/tests/macWinMenu.test new file mode 100644 index 0000000..7b6ac12 --- /dev/null +++ b/tests/macWinMenu.test @@ -0,0 +1,117 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) macWinMenu.test 1.13 97/04/10 14:41:29 + +if {$tcl_platform(platform) == "unix"} { + return +} + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +proc deleteWindows {} { + foreach i [winfo children .] { + catch [destroy $i] + } +} + +deleteWindows +wm geometry . {} +raise . + +if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} { + puts " Some tests were skipped because they could not be performed" + puts " automatically on this platform. If you wish to execute them" + puts " interactively, set the TCL variable INTERACTIVE and re-run" + puts " the test." +} + +test macWinMenu-1.1 {PreprocessMenu} { + 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 {}} +if {$tcl_platform(platform) != "windows" || [info exists INTERACTIVE]} { + test macWinMenu-1.2 {PreprocessMenu} { + 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} { + 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} { + 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} { + 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"} {}} + +if {$tcl_platform(platform) != "windows" || [info exists INTERACTIVE]} { + test macWinMenu-2.1 {TkPreprocessMenu} { + 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 {} {}} +} + +deleteWindows diff --git a/tests/macscrollbar.test b/tests/macscrollbar.test new file mode 100644 index 0000000..0dd6646 --- /dev/null +++ b/tests/macscrollbar.test @@ -0,0 +1,101 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) macscrollbar.test 1.3 97/06/24 13:48:34 + +# Only run this test on the Macintosh +if {$tcl_platform(platform) != "macintosh"} return + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . +update + +# Tests for display and layout +wm geometry . 50x300 +scrollbar .s +pack .s -fill y -expand 1 +update +test macscroll-1.1 {TkpDisplayScrollbar procedure} { + list [.s configure -width] [.s configure -bd] +} {{-width width Width 16 16} {-borderwidth borderWidth BorderWidth 0 0}} +test macscroll-1.2 {TkpDisplayScrollbar procedure} { + # 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} { + 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} { + 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} { + 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} { + # 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} { + 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 +} {} + +foreach i [winfo children .] { + destroy $i +} +concat {} diff --git a/tests/main.test b/tests/main.test new file mode 100644 index 0000000..49365c3 --- /dev/null +++ b/tests/main.test @@ -0,0 +1,31 @@ +# This file contains tests for the tkMain.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) main.test 1.2 97/09/10 17:49:20 + +if {[info procs test] != "test"} { + source defs +} + +test main-1.1 {StdinProc} {unixOnly} { + catch {removeFile script} + set fd [open script w] + puts $fd { + close stdin; exit + } + close $fd + if {[catch {exec $tktest <script} msg]} { + set error 1 + } else { + set error 0 + } + list $error $msg +} {0 {}} diff --git a/tests/menu.test b/tests/menu.test new file mode 100644 index 0000000..3f54a8d --- /dev/null +++ b/tests/menu.test @@ -0,0 +1,2385 @@ +# This file is a Tcl script to test menus in Tk. It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) menu.test 1.43 97/10/28 13:51:13 + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} { + puts " Some tests were skipped because they could not be performed" + puts " automatically on this platform. If you wish to execute them" + puts " interactively, set the TCL variable INTERACTIVE and re-run" + puts " the test." + set testConfig(menuInteractive) 0 +} else { + set testConfig(menuInteractive) 1 +} + +proc deleteWindows {} { + foreach i [winfo children .] { + catch [destroy $i] + } +} + +deleteWindows +wm geometry . {} +raise . + +test menu-1.1 {Tk_MenuCmd procedure} { + list [catch menu msg] $msg +} {1 {wrong # args: should be "menu pathName ?options?"}} +test menu-1.2 {Tk_MenuCmd procedure} { + list [catch "menu bogus" msg] $msg +} {1 {bad window path name "bogus"}} +test menu-1.3 {Tk_MenuCmd procedure} { + list [catch "menu .m1 foo" msg] $msg +} {1 {unknown option "foo"}} +test menu-1.4 {Tk_MenuCmd procedure} { + catch {destroy .m1} + list [catch {menu .m1} msg] $msg [destroy .m1] +} {0 .m1 {}} +test menu-1.5 {Tk_MenuCmd - creating menubar} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label Test -menu "" + list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] +} {{} {} {}} +test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} { + catch {destroy .t2} + catch {destroy .m1} + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + list [catch {menu .m1} msg] $msg [destroy .m1 .t2] +} {0 .m1 {}} +test menu-1.7 {Tk_MenuCmd procedure one clone cascade} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .t2} + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + menu .m1 + .m1 add cascade -menu .m2 + list [catch {menu .m2} msg] $msg [destroy .t2 .m1 .m2] +} {0 .m2 {}} +test menu-1.8 {Tk_MenuCmd procedure two clone cascades} { + catch {destroy .m1} + catch {destroy .t2} + catch {destroy .t3} + catch {destroy .m2} + menu .m1 + .m1 add cascade -menu .m2 + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + toplevel .t3 -menu .m1 + wm geometry .t3 +0+0 + list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2] +} {0 .m2 {}} +test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} { + catch {destroy .t2} + catch {destroy .m1} + catch {destroy .t3} + catch {destroy .m2} + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + menu .m1 + .m1 add cascade -menu .m2 + toplevel .t3 -menu .m1 + wm geometry .t3 +0+0 + list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2] +} {0 .m2 {}} +test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} { + catch {destroy .t2} + catch {destroy .t3} + catch {destroy .m1} + catch {destroy .m2} + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + toplevel .t3 -menu .m1 + wm geometry .t3 +0+0 + menu .m1 + .m1 add cascade -menu .m2 + list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2] +} {0 .m2 {}} +test menu-1.11 {Tk_MenuCmd procedure three clones cascades} { + catch {destroy .t2} + catch {destroy .t3} + catch {destroy .t4} + catch {destroy .m1} + catch {destroy .m2} + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + toplevel .t3 -menu .m1 + wm geometry .t3 +0+0 + toplevel .t4 -menu .m1 + wm geometry .t4 +0+0 + menu .m1 + .m1 add cascade -menu .m2 + list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .t4 .m1 .m2] +} {0 .m2 {}} +test menu-1.12 {Tk_MenuCmd procedure} { + catch {destroy .t2} + catch {destroy .m1} + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + list [catch {menu .m1} msg] $msg [destroy .t2 .m1] +} {0 .m1 {}} +test menu-1.13 {Tk_MenuCmd procedure} { + catch {destroy .t2} + catch {destroy .t3} + catch {destroy .m1} + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + toplevel .t3 -menu .m1 + wm geometry .t3 +0+0 + list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .m1] +} {0 .m1 {}} +test menu-1.14 {Tk_MenuCmd procedure} { + catch {destroy .t2} + catch {destroy .t3} + catch {destroy .t4} + catch {destroy .m1} + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + toplevel .t3 -menu .m1 + wm geometry .t3 +0+0 + toplevel .t4 -menu .m1 + wm geometry .t4 +0+0 + list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .t4 .m1] +} {0 .m1 {}} + +catch {destroy .m1} +menu .m1 +set i 1 +foreach test { + {-activebackground #012345 #012345 non-existent + {unknown color name "non-existent"}} + {-activeborderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-activeforeground #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-background #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-bg #110022 #110022 bogus {unknown color name "bogus"}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} + {-fg #110022 #110022 bogus {unknown color name "bogus"}} + {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {} + {font "" doesn't exist}} + {-foreground #110022 #110022 bogus {unknown color name "bogus"}} + {-postcommand "any old string" "any old string" {} {}} + {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}} + {-takefocus "any string" "any string" {} {}} + {-tearoff 0 0} + {-tearoff 1 1} + {-tearoffcommand "any old string" "any old string" {} {}} +} { + set name [lindex $test 0] + test menu-2.$i {configuration options} { + .m1 configure $name [lindex $test 1] + lindex [.m1 configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test menu-2.$i {configuration options} { + list [catch {.m1 configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .m1 configure $name [lindex [.m1 configure $name] 3] + incr i +} +destroy .m1 + +# We need to test all of the options with all of the different types of +# menu entries. The following code sets up .m1 with 6 items. It then +# runs through the big table below it. +# index 0 is tearoff, 1 command, 2 cascade, 3 separator, 4 checkbutton, +# 5 radiobutton + +menu .m1 +.m1 add command -label "command" +menu .m2 +.m2 add command -label "test" +.m1 add cascade -label "cascade" -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] + +foreach test { + {-activebackground + {{#012345 + {{unknown option "-activebackground"} #012345 #012345 + {unknown option "-activebackground"} #012345 #012345 + } + } + {non-existent + {{unknown option "-activebackground"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + {unknown option "-activebackground"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + } + }} + } + {-activeforeground + {{#ff0000 + {{unknown option "-activeforeground"} + #ff0000 #ff0000 {unknown option "-activeforeground"} #ff0000 #ff0000 + } + } + {non-existent + {{unknown option "-activeforeground"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + {unknown option "-activeforeground"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + } + }} + } + {-accelerator + {{"Ctrl+S" + {{unknown option "-accelerator"} + "Ctrl+S" "Ctrl+S" {unknown option "-accelerator"} + "Ctrl+S" "Ctrl+S" + } + }} + } + {-background + {{#ff0000 + {#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 + } + } + {non-existent + {{unknown color name "non-existent"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + } + }} + } + {-bitmap + {{questhead + {{unknown option "-bitmap"} questhead questhead + {unknown option "-bitmap"} questhead questhead + } + } + {badValue + {{unknown option "-bitmap"} + {bitmap "badValue" not defined} + {bitmap "badValue" not defined} + {unknown option "-bitmap"} + {bitmap "badValue" not defined} + {bitmap "badValue" not defined} + } + }} + } + {-columnbreak + {{1 + {{unknown option "-columnbreak"} 1 1 {unknown option "-columnbreak"} 1 1} + }} + } + {-command + {{beep + {{unknown option "-command"} beep beep + {unknown option "-command"} beep beep + } + }} + } + {-font + {{-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + {{unknown option "-font"} + -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + {unknown option "-font"} + -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + } + } + {{kill rock stars} + {{unknown option "-font"} + {expected integer but got "rock"} + {expected integer but got "rock"} + {unknown option "-font"} + {expected integer but got "rock"} + {expected integer but got "rock"} + } + }} + } + {-foreground + {{#110022 + {{unknown option "-foreground"} #110022 #110022 + {unknown option "-foreground"} #110022 #110022 + } + } + {non-existent + {{unknown option "-foreground"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + {unknown option "-foreground"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + } + }} + } + {-image + {{image1 + {{unknown option "-image"} image1 image1 + {unknown option "-image"} image1 image1 + } + } + {bogus + {{unknown option "-image"} + {image "bogus" doesn't exist} + {image "bogus" doesn't exist} + {unknown option "-image"} + {image "bogus" doesn't exist} + {image "bogus" doesn't exist} + } + } + {"" + {{unknown option "-image"} + {} + {} + {unknown option "-image"} + {} + {} + } + }} + } + {-indicatoron + {{1 + {{unknown option "-indicatoron"} + {unknown option "-indicatoron"} + {unknown option "-indicatoron"} + {unknown option "-indicatoron"} 1 1 + } + }} + } + {-label + {{test + {{unknown option "-label"} test test + {unknown option "-label"} test test + } + }} + } + {-menu + {{.m2 + {{unknown option "-menu"} + {unknown option "-menu"} .m2 + {unknown option "-menu"} + {unknown option "-menu"} + {unknown option "-menu"} + } + }} + } + {-offvalue + {{off + {{unknown option "-offvalue"} + {unknown option "-offvalue"} + {unknown option "-offvalue"} + {unknown option "-offvalue"} + off + {unknown option "-offvalue"} + } + }} + } + {-onvalue + {{on + {{unknown option "-onvalue"} + {unknown option "-onvalue"} + {unknown option "-onvalue"} + {unknown option "-onvalue"} + on + {unknown option "-onvalue"} + } + }} + } + {-selectcolor + {{#110022 + {{unknown option "-selectcolor"} + {unknown option "-selectcolor"} + {unknown option "-selectcolor"} + {unknown option "-selectcolor"} + #110022 + #110022 + } + } + {non-existent + {{unknown option "-selectcolor"} + {unknown option "-selectcolor"} + {unknown option "-selectcolor"} + {unknown option "-selectcolor"} + {unknown color name "non-existent"} + {unknown color name "non-existent"} + } + }} + } + {-selectimage + {{image1 + {{unknown option "-selectimage"} + {unknown option "-selectimage"} + {unknown option "-selectimage"} + {unknown option "-selectimage"} image1 image1 + } + } + {bogus + {{unknown option "-selectimage"} + {unknown option "-selectimage"} + {unknown option "-selectimage"} + {unknown option "-selectimage"} + {image "bogus" doesn't exist} + {image "bogus" doesn't exist} + } + } + {"" + {{unknown option "-selectimage"} + {unknown option "-selectimage"} + {unknown option "-selectimage"} + {unknown option "-selectimage"} + {} + {} + } + }} + } + {-state + {{normal + {normal normal normal + {unknown option "-state"} normal normal + } + }} + } + {-value + {{"any string" + {{unknown option "-value"} + {unknown option "-value"} + {unknown option "-value"} + {unknown option "-value"} + {unknown option "-value"} "any string" + } + }} + } + {-variable + {{"any string" + {{unknown option "-variable"} + {unknown option "-variable"} + {unknown option "-variable"} + {unknown option "-variable"} + "any string" + "any string" + } + }} + } + {-underline + {{0 + {{unknown option "-underline"} 0 0 + {unknown option "-underline"} 0 0 + } + } + {3p + {{unknown option "-underline"} + {expected integer but got "3p"} + {expected integer but got "3p"} + {unknown option "-underline"} + {expected integer but got "3p"} + {expected integer but got "3p"} + } + }} + } +} { + set name [lindex $test 0] + foreach attempt [lindex $test 1] { + set value [lindex $attempt 0] + 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] { + set result [catch {.m1 entryconfigure $item $name $value} msg] + if {$result == 1} { + set msg + } else { + lindex [.m1 entryconfigure $item $name] 4 + } + } [lindex $options $item] + incr i + } + } +} + +image delete image1 +destroy .m1 +destroy .m2 + +test menu-3.1 {MenuWidgetCmd procedure} { + catch {destroy .m1} + menu .m1 + list [catch {.m1} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 option ?arg arg ...?"} {}} +test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} {menuInteractive} { + catch {destroy .m1} + menu .m1 -postcommand "destroy .m1" + .m1 add command -label "menu-3.2: Hit Escape" + list [catch {.m1 post 40 40} msg] $msg +} {0 {}} +test menu-3.3 {MenuWidgetCmd procedure, "activate" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 activate} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 activate index"} {}} +test menu-3.4 {MenuWidgetCmd procedure, "activate" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 activate "foo"} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-3.5 {MenuWidgetCmd procedure, "activate" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 add separator + list [catch {.m1 activate 2} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.6 {MenuWidgetCmd procedure, "activate" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 entryconfigure 1 -state disabled + list [catch {.m1 activate 1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.7 {MenuWidgetCmd procedure, "activate" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 activate 1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.8 {MenuWidgetCmd procedure, "add" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 add type ?options?"} {}} +test menu-3.9 {MenuWidgetCmd procedure, "add" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add foo} msg] $msg [destroy .m1] +} {1 {bad menu entry type "foo": must be cascade, checkbutton, command, radiobutton, or separator} {}} +test menu-3.10 {MenuWidgetCmd procedure, "add" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add separator} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.11 {MenuWidgetCmd procedure, "cget" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 cget} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 cget option"} {}} +test menu-3.12 {MenuWidgetCmd procedure, "cget" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 cget -gorp} msg] $msg [destroy .m1] +} {1 {unknown option "-gorp"} {}} +test menu-3.13 {MenuWidgetCmd procedure, "cget" option} { + catch {destroy .m1} + menu .m1 + .m1 configure -postcommand "Some string" + list [catch {.m1 cget -postcommand} msg] $msg [destroy .m1] +} {0 {Some string} {}} +test menu-3.14 {MenuWidgetCmd procedure, "clone" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 clone} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 clone newMenuName ?menuType?"} {}} +test menu-3.15 {MenuWidgetCmd procedure, "clone" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 clone a b c d} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 clone newMenuName ?menuType?"} {}} +test menu-3.16 {MenuWidgetCmd procedure, "clone" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 clone .m1.clone1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.17 {MenuWidgetCmd procedure, "clone" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 clone .m1.clone1 tearoff} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.18 {MenuWidgetCmd procedure, "configure" option} { + catch {destroy .m1} + menu .m1 + list [catch {llength [.m1 configure]} msg] $msg [destroy .m1] +} {0 20 {}} +test menu-3.19 {MenuWidgetCmd procedure, "configure" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 configure -gorp} msg] $msg [destroy .m1] +} {1 {unknown option "-gorp"} {}} +test menu-3.20 {MenuWidgetCmd procedure, "configure" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 configure -postcommand "A random String"} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.21 {MenuWidgetCmd procedure, "configure" option} { + catch {destroy .m1} + menu .m1 + .m1 configure -postcommand "Another string" + list [catch {lindex [.m1 configure -postcommand] 4} msg] $msg [destroy .m1] +} {0 {Another string} {}} +test menu-3.22 {MenuWidgetCmd procedure, "delete" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 delete} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 delete first ?last?"} {}} +test menu-3.23 {MenuWidgetCmd procedure, "delete" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 delete foo} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-3.24 {MenuWidgetCmd procedure, "delete" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 delete 0 "foo"} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-3.25 {MenuWidgetCmd procedure, "delete" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 delete 0} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.26 {MenuWidgetCmd procedure, "delete" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + list [catch {.m1 delete 1 0} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.27 {MenuWidgetCmd procedure, "delete" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "1" + .m1 add command -label "2" + .m1 add command -label "3" + list [catch {.m1 delete 1 3} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.28 {MenuWidgetCmd procedure, "delete" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "1" + .m1 add command -label "2" + .m1 add command -label "3" + .m1 activate 2 + list [catch {.m1 delete 1 3} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.29 {MenuWidgetCmd procedure, "delete" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "1" + .m1 add command -label "2" + .m1 add command -label "3" + .m1 activate 3 + list [catch {.m1 delete 1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.30 {MenuWidgetCmd procedure, "entrycget" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 entrycget} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 entrycget index option"} {}} +test menu-3.31 {MenuWidgetCmd procedure, "entrycget" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 entrycget index option foo} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 entrycget index option"} {}} +test menu-3.32 {MenuWidgetCmd procedure, "entrycget" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 entrycget foo -label} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-3.33 {MenuWidgetCmd procedure, "entrycget" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] +} {0 test {}} +test menu-3.34 {MenuWidgetCmd procedure, "entryconfigure" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 entryconfigure} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 entryconfigure index ?option value ...?"} {}} +test menu-3.35 {MenuWidgetCmd procedure, "entryconfigure" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 entryconfigure foo} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-3.36 {MenuWidgetCmd procedure, "entryconfigure" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {llength [.m1 entryconfigure 1]} msg] $msg [destroy .m1] +} {0 14 {}} +test menu-3.37 {MenuWidgetCmd procedure, "entryconfigure" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {lindex [.m1 entryconfigure 1 -label] 4} msg] $msg [destroy .m1] +} {0 test {}} +test menu-3.38 {MenuWidgetCmd procedure, "entryconfigure" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 entryconfigure 1 -label "changed" + list [catch {lindex [.m1 entryconfigure 1 -label] 4} msg] $msg [destroy .m1] +} {0 changed {}} +test menu-3.39 {MenuWidgetCmd procedure, "index" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 index} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 index string"} {}} +test menu-3.40 {MenuWidgetCmd procedure, "index" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 index foo} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-3.41 {MenuWidgetCmd procedure, "index" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 index "test"} msg] $msg [destroy .m1] +} {0 1 {}} +test menu-3.42 {MenuWidgetCmd procedure, "insert" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 insert} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 insert index type ?options?"} {}} +test menu-3.43 {MenuWidgetCmd procedure, "insert" option} { + catch {destroy .m1} + menu .m1 + .m1 insert 1 command -label "test" + list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] +} {0 test {}} +test menu-3.44 {MenuWidgetCmd procedure, "invoke" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 invoke} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 invoke index"} {}} +test menu-3.45 {MenuWidgetCmd procedure, "invoke" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 invoke foo} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-3.46 {MenuWidgetCmd procedure, "invoke" option} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add command -label "set foo" -command "set foo hello" + list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 hello 0 hello 0 {} {}} +test menu-3.47 {MenuWidgetCmd procedure, "post" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "On Windows, hit Escape to get this menu to go away" + list [catch {.m1 post} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 post x y"} {}} +test menu-3.48 {MenuWidgetCmd procedure, "post" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 post foo 40} msg] $msg [destroy .m1] +} {1 {expected integer but got "foo"} {}} +test menu-3.49 {MenuWidgetCmd procedure, "post" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 post 40 bar} msg] $msg [destroy .m1] +} {1 {expected integer but got "bar"} {}} +test menu-3.50 {MenuWidgetCmd procedure, "post" option} {menuInteractive} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "menu-3.53: hit Escape" -command "puts hello" + list [catch {.m1 post 40 40} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.51 {MenuWidgetCmd procedure, "postcascade" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 postcascade} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 postcascade index"} {}} +test menu-3.52 {MenuWidgetCmd procedure, "postcascade" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 postcascade foo} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} {menuInteractive} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add command -label "menu-3.56 - hit Escape" + menu .m2 + .m1 post 40 40 + .m1 add cascade -menu .m2 + list [catch {.m1 postcascade 1} msg] $msg [destroy .m1 .m2] +} {0 {} {}} +test menu-3.54 {MenuWidgetCmd procedure, "postcascade" option} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + .m1 add cascade -menu .m2 -label "menu-3.57 - hit Escape" + .m1 postcascade 1 + list [catch {.m1 postcascade none} msg] $msg [destroy .m1 .m2] +} {0 {} {}} +test menu-3.55 {MenuWidgetCmd procedure, "type" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 type} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 type index"} {}} +test menu-3.56 {MenuWidgetCmd procedure, "type" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 type foo} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-3.57 {MenuWidgetCmd procedure, "type" option} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 type 1} msg] $msg [destroy .m1] +} {0 command {}} +test menu-3.58 {MenuWidgetCmd procedure, "type" option} { + catch {destroy .m1} + menu .m1 + .m1 add separator + list [catch {.m1 type 1} msg] $msg [destroy .m1] +} {0 separator {}} +test menu-3.59 {MenuWidgetCmd procedure, "type" option} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label "test" + list [catch {.m1 type 1} msg] $msg [destroy .m1] +} {0 checkbutton {}} +test menu-3.60 {MenuWidgetCmd procedure, "type" option} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -label "test" + list [catch {.m1 type 1} msg] $msg [destroy .m1] +} {0 radiobutton {}} +test menu-3.61 {MenuWidgetCmd procedure, "type" option} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label "test" + list [catch {.m1 type 1} msg] $msg [destroy .m1] +} {0 cascade {}} +test menu-3.62 {MenuWidgetCmd procedure, "type" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 type 0} msg] $msg [destroy .m1] +} {0 tearoff {}} +test menu-3.63 {MenuWidgetCmd procedure, "unpost" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 unpost foo} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 unpost"} {}} +test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} {menuInteractive} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "menu-3.68 - hit Escape" + .m1 post 40 40 + list [catch {.m1 unpost} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-3.65 {MenuWidgetCmd procedure, "yposition" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 yposition} msg] $msg [destroy .m1] +} {1 {wrong # args: should be ".m1 yposition index"} {}} +test menu-3.66 {MenuWidgetCmd procedure, "yposition" option} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 yposition 1}] [destroy .m1] +} {0 {}} +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} {}} + +test menu-4.1 {TkInvokeMenu} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 invoke 0} msg] [destroy .m1] +} {0 {}} +test menu-4.2 {TkInvokeMenu} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off + list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 {} 0 on 0 {} {}} +test menu-4.3 {TkInvokeMenu} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off + .m1 invoke 1 + list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 {} 0 off 0 {} {}} +test menu-4.4 {TkInvokeMenu} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add radiobutton -label "1" -variable foo -value one + .m1 add radiobutton -label "2" -variable foo -value two + .m1 add radiobutton -label "3" -variable foo -value three + list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 {} 0 one 0 {} {}} +test menu-4.5 {TkInvokeMenu} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add radiobutton -label "1" -variable foo -value one + .m1 add radiobutton -label "2" -variable foo -value two + .m1 add radiobutton -label "3" -variable foo -value three + list [catch {.m1 invoke 2} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 {} 0 two 0 {} {}} +test menu-4.6 {TkInvokeMenu} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add radiobutton -label "1" -variable foo -value one + .m1 add radiobutton -label "2" -variable foo -value two + .m1 add radiobutton -label "3" -variable foo -value three + list [catch {.m1 invoke 3} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 {} 0 three 0 {} {}} +test menu-4.7 {TkInvokeMenu} { + catch {destroy .m1} + catch {unset menu_test} + menu .m1 + .m1 add command -label "test" -command "set menu_test menu-4.8" + list [catch {.m1 invoke 1} msg] $msg [catch {set menu_test} msg2] $msg2 [catch {unset menu_test} msg3] $msg3 [destroy .m1] +} {0 menu-4.8 0 menu-4.8 0 {} {}} +test menu-4.8 {TkInvokeMenu} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label "test" -menu .m1.m2 + list [catch {.m1 invoke 1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-4.9 {TkInvokeMenu} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" -command ".m1 delete 1" + list [catch {.m1 invoke 1} msg] $msg [catch {.m1 type "test"} msg2] $msg2 [destroy .m1] +} {0 {} 1 {bad menu entry index "test"} {}} + +test menu-5.1 {DestroyMenuInstance} { + catch {destroy .m1} + menu .m1 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-5.2 {DestroyMenuInstance - cascade menu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add cascade -menu .m2 + menu .m2 + list [catch {destroy .m2} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-5.3 {DestroyMenuInstance - multiple cascade parents} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + .m1 add cascade -menu .m3 + menu .m2 + .m2 add cascade -menu .m3 + menu .m3 + list [catch {destroy .m3} msg] $msg [destroy .m1 .m2] +} {0 {} {}} +test menu-5.4 {DestroyMenuInstance - multiple cascade parents} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + catch {destroy .m4} + menu .m1 + .m1 add cascade -menu .m4 + menu .m2 + .m2 add cascade -menu .m4 + menu .m3 + .m3 add cascade -menu .m4 + menu .m4 + list [catch {destroy .m4} msg] $msg [destroy .m1 .m2 .m3] +} {0 {} {}} +test menu-5.5 {DestroyMenuInstance - cascades of cloned menus} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + .m1 add cascade -menu .m2 + . configure -menu .m1 + list [catch {destroy .m2} msg] $msg [.m1 entrycget 1 -menu] [. configure -menu ""] [destroy .m1] +} {0 {} .m2 {} {}} +test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .t2} + menu .m1 + .m1 add cascade -menu .m2 + menu .m2 + . configure -menu .m1 + toplevel .t2 + wm geometry .t2 +0+0 + .t2 configure -menu .m1 + list [catch {destroy .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1] +} {0 {} {} {}} +test menu-5.7 {DestroyMenuInstance - basic clones} { + catch {destroy .m1} + menu .m1 + set tearoff [tkTearOffMenu .m1] + list [catch {destroy $tearoff} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-5.8 {DestroyMenuInstance - multiple clones} { + catch {destroy .m1} + menu .m1 + set tearoff1 [tkTearOffMenu .m1] + set tearoff2 [tkTearOffMenu .m1] + list [catch {destroy $tearoff1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-5.9 {DestroyMenuInstace - master menu} { + catch {destroy .m1} + menu .m1 + tkTearOffMenu .m1 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-5.10 {DestroyMenuInstance - freeing entries} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-5.11 {DestroyMenuInstace - no entries} { + catch {destroy .m1} + menu .m1 + .m1 configure -tearoff 0 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-5.12 {DestroyMenuInstance - platform data} { + catch {destroy .m1} + menu .m1 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-5.13 {DestroyMenuInstance - clones when mismatched tearoffs} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + .m1 add cascade -menu .m2 + set tearoff [tkTearOffMenu .m1 40 40] + list [destroy .m2] [destroy .m1] +} {{} {}} + +test menu-6.1 {TkDestroyMenu} { + catch {destroy .m1} + menu .m1 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-6.2 {TkDestroyMenu - reentrancy} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + bind .m1 <Destroy> {destroy .m1} + menu .m2 + bind .m2 <Destroy> {destroy .m2} + list [catch {destroy .m1} msg] $msg [destroy .m2] +} {0 {} {}} +test menu-6.3 {TkDestroyMenu - reentrancy} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + bind .m1 <Destroy> {destroy .m2} + .m1 clone .m2 + .m1 clone .m3 + list [catch {destroy .m1} msg] $msg [winfo exists .m2] +} {0 {} 0} +test menu-6.4 {TkDestroyMenu - reentrancy - clones} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 clone .m2 + .m1 clone .m1.m3 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-6.5 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 clone .m2 + destroy .m1 + winfo exists .m2 +} {0} +test menu-6.6 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 clone .m2 tearoff + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-6.7 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 clone .m2 + destroy .m2 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-6.8 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + .m1 clone .m2 + .m1 clone .m3 + destroy .m1 + list [winfo exists .m2] [winfo exists .m3] +} {0 0} +test menu-6.9 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + .m1 clone .m2 + .m1 clone .m3 + list [catch {destroy .m2} msg] $msg [catch {destroy .m3} msg2] $msg2 [catch {destroy .m1} msg3] $msg3 +} {0 {} 0 {} 0 {}} +test menu-6.10 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + .m1 clone .m2 + .m1 clone .m3 + list [catch {destroy .m3} msg] $msg [catch {destroy .m1} msg2] $msg2 +} {0 {} 0 {}} +test menu-6.11 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + catch {destroy .m4} + menu .m1 + .m1 clone .m2 + .m1 clone .m3 + .m1 clone .m4 + list [catch {destroy .m2} msg1] $msg1 [catch {destroy .m1} msg2] $msg2 +} {0 {} 0 {}} +test menu-6.12 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + catch {destroy .m4} + menu .m1 + .m1 clone .m2 + .m1 clone .m3 + .m1 clone .m4 + list [catch {destroy .m3} msg1] $msg1 [catch {destroy .m1} msg2] $msg2 +} {0 {} 0 {}} +test menu-6.13 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + catch {destroy .m4} + menu .m1 + .m1 clone .m2 + .m1 clone .m3 + .m1 clone .m4 + list [catch {destroy .m4} msg1] $msg1 [catch {destroy .m1} msg2] $msg2 +} {0 {} 0 {}} +test menu-6.14 {TkDestroyMenu} { + catch {destroy .m1} + menu .m1 + . configure -menu .m1 + list [catch {destroy .m1} msg] $msg [. configure -menu ""] +} {0 {} {}} +test menu-6.15 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .t2} + menu .m1 + toplevel .t2 + wm geometry .t2 +0+0 + . configure -menu .m1 + .t2 configure -menu .m1 + list [catch {destroy .m1} msg] $msg [destroy .t2] [. configure -menu ""] +} {0 {} {} {}} +test menu-6.16 {TkDestroyMenu} { + catch {destroy .m1} + catch {destroy .t2} + catch {destroy .t3} + menu .m1 + toplevel .t2 + wm geometry .t2 +0+0 + toplevel .t3 + wm geometry .t3 +0+0 + . configure -menu .m1 + .t2 configure -menu .m1 + .t3 configure -menu .m1 + list [catch {destroy .m1} msg] $msg [destroy .t2] [destroy .t3] [. configure -menu ""] +} {0 {} {} {} {}} + +test menu-7.1 {UnhookCascadeEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-7.2 {UnhookCascadeEntry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -menu .m2 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-7.3 {UnhookCascadeEntry} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + .m2 add cascade -menu .cascade + .m1 add cascade -menu .cascade + list [catch {destroy .m1} msg] $msg [destroy .m2] +} {0 {} {}} +test menu-7.4 {UnhookCascadeEntry} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + .m1 add cascade -menu .cascade + .m2 add cascade -menu .cascade + list [catch {destroy .m1} msg] $msg [destroy .m2] +} {0 {} {}} +test menu-7.5 {UnhookCascadeEntry} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + menu .m2 + menu .m3 + .m1 add cascade -menu .cascade + .m2 add cascade -menu .cascade + .m3 add cascade -menu .cascade + list [catch {destroy .m1} msg] $msg [destroy .m2 .m3] +} {0 {} {}} +test menu-7.6 {UnhookCascadeEntry} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + menu .m2 + menu .m3 + .m1 add cascade -menu .cascade + .m2 add cascade -menu .cascade + .m3 add cascade -menu .cascade + list [catch {destroy .m2} msg] $msg [destroy .m1 .m3] +} {0 {} {}} +test menu-7.7 {UnhookCascadeEntry} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + menu .m2 + menu .m3 + .m1 add cascade -menu .cascade + .m2 add cascade -menu .cascade + .m3 add cascade -menu .cascade + list [catch {destroy .m3} msg] $msg [destroy .m1 .m2] +} {0 {} {}} +test menu-7.8 {UnhookCascadeEntry} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + .m1 add cascade -menu .m2 + list [catch {destroy .m1} msg] $msg [destroy .m2] +} {0 {} {}} +test menu-7.9 {UnhookCascadeEntry} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + .m1 add cascade -menu .m2 + destroy .m1 + list [catch {destroy .m2} msg] $msg +} {0 {}} + +test menu-8.1 {DestroyMenuEntry} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + .m1 add cascade -menu .m2 + list [catch {.m1 delete 1} msg] $msg [destroy .m1 .m2] +} {0 {} {}} +test menu-8.2 {DestroyMenuEntry} { + catch {image delete image1a} + catch {destroy .m1} + image create photo image1a -file [file join $tk_library demos images earth.gif] + menu .m1 + .m1 add command -image image1a + list [catch {.m1 delete 1} msg] $msg [destroy .m1] [image delete image1a] +} {0 {} {} {}} +test menu-8.3 {DestroyMenuEntry} { + catch {eval image delete [image names]} + catch {destroy .m1} + image create test image1 + image create test image2 + menu .m1 + .m1 add checkbutton -image image1 -selectimage image2 + .m1 invoke 1 + list [catch {.m1 delete 1} msg] $msg [destroy .m1] [eval image delete [image names]] +} {0 {} {} {}} +test menu-8.4 {DestroyMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -variable foo + list [catch {.m1 delete 1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-8.5 {DestroyMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 delete 1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-8.6 {DestroyMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "one" + .m1 add command -label "two" + list [catch {.m1 delete 1} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] +} {0 {} two {}} +test menu-8.7 {DestroyMenuEntry} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add command -label "one" + .m1 clone .m2 tearoff + list [catch {.m2 delete 0} msg] $msg [destroy .m1] +} {0 {} {}} + +# test menu-9 - Can only change when fonts change on system, which cannot +# be done from tcl. + +test menu-9.1 {ConfigureMenu} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 configure -postcommand "beep"} msg] $msg [.m1 cget -postcommand] [destroy .m1] +} {0 {} beep {}} +test menu-9.2 {ConfigureMenu} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 configure -tearoff 0} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] +} {0 {} test {}} +test menu-9.3 {ConfigureMenu} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 configure -postcommand "beep"} msg] $msg [.m1 cget -postcommand] [destroy .m1] +} {0 {} beep {}} +test menu-9.4 {ConfigureMenu} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 configure -fg red} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-9.5 {ConfigureMenu} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 add command -label "two" + list [catch {.m1 configure -fg red} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-9.6 {ConfigureMenu} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 add command -label "two" + .m1 add command -label "three" + list [catch {.m1 configure -fg red} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-9.7 {ConfigureMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 clone .m2 tearoff + list [catch {.m1 configure -fg red} msg] $msg [.m2 cget -fg] [destroy .m1] +} {0 {} red {}} +test menu-9.8 {ConfigureMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 clone .m2 tearoff + list [catch {.m2 configure -fg red} msg] $msg [.m1 cget -fg] [destroy .m1] +} {0 {} red {}} +test menu-9.9 {ConfigureMenu} { + catch {destroy .m1} + menu .m1 + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} + +test menu-10.1 {ConfigureMenuEntry} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add checkbutton -variable foo -onvalue on -offvalue off -label "Nonsense" + list [catch {.m1 entryconfigure 1 -variable bar} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] +} {0 {} bar {}} +test menu-10.2 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 entryconfigure 1 -label ""} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] +} {0 {} {} {}} +test menu-10.3 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command + list [catch {.m1 entryconfigure 1 -label "test"} cmd] $cmd [.m1 entrycget 1 -label] [destroy .m1] +} {0 {} test {}} +test menu-10.4 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command + list [catch {.m1 entryconfigure 1 -accel "S"} msg] $msg [.m1 entrycget 1 -accel] [destroy .m1] +} {0 {} S {}} +test menu-10.5 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command + list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] +} {0 {} test {}} +test menu-10.6 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command + list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-10.7 {ConfigureMenuEntry} { + catch {destroy .m1} + catch {destroy .m2} + menu .m2 + menu .m1 + .m1 add cascade + list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1 .m2] +} {0 {} {}} +test menu-10.8 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade + list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-10.9 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -menu .m3 + list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-10.10 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade + list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-10.11 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -menu .m2 + list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-10.12 {ConfigureMenuEntry} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + catch {destroy .m4} + catch {destroy .m5} + menu .m1 + menu .m2 + .m2 add cascade -menu .m1 + menu .m3 + .m3 add cascade -menu .m1 + menu .m4 + .m4 add cascade -menu .m1 + menu .m5 + .m5 add cascade + list [catch {.m5 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4 .m5] +} {0 {} {}} +test menu-10.13 {ConfigureMenuEntry} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + catch {destroy .m4} + menu .m1 + menu .m2 + .m2 add cascade -menu .m1 + menu .m3 + .m3 add cascade -menu .m1 + menu .m4 + .m4 add cascade -menu .m1 + list [catch {.m3 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4] +} {0 {} {}} +test menu-10.14 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton + list [catch {.m1 entryconfigure 1 -variable "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] +} {0 {} test {}} +test menu-10.15 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add checkbutton -label "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] +} {0 {} test {}} +test menu-10.16 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add radiobutton -label "test"} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-10.17 {ConfigureMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton + list [catch {.m1 entryconfigure 1 -onvalue "test"} msg] $msg [.m1 entrycget 1 -onvalue] [destroy .m1] +} {0 {} test {}} +test menu-10.18 {ConfigureMenuEntry} { + catch {destroy .m1} + catch {image delete image1} + menu .m1 + .m1 add command + image create test image1 + list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1] +} {0 {} {} {}} +test menu-10.19 {ConfigureMenuEntry} { + 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] + 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-10.20 {ConfigureMenuEntry} { + 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 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-10.21 {ConfigureMenuEntry} { + 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 test image2 + image create test image3 + menu .m1 + .m1 add checkbutton -image image1 -selectimage image2 + list [catch {.m1 entryconfigure 1 -selectimage image3} msg] $msg [destroy .m1] [image delete image1] [image delete image2] [image delete image3] +} {0 {} {} {} {} {}} + +test menu-11.1 {ConfigureMenuCloneEntries} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + .m1 clone .m2 + .m2 configure -tearoff 0 + .m1 clone .m3 + .m1 add command -label "test" + .m1 add command -label "test2" + list [list [catch {.m1 entryconfigure 1 -gork "foo"} msg] $msg] [destroy .m1] +} {{1 {unknown option "-gork"}} {}} +test menu-11.2 {ConfigureMenuCloneEntries} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + catch {destroy .m4} + menu .m1 + .m1 clone .m2 + menu .m3 + .m1 add cascade -menu .m3 + menu .m4 + list [catch {.m1 entryconfigure 1 -menu .m4} msg] $msg [destroy .m1] [destroy .m3] [destroy .m4] +} {0 {} {} {} {}} +test menu-11.3 {ConfigureMenuCloneEntries} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 clone .m2 + .m1 add cascade -label dummy + list [catch {.m1 entryconfigure dummy -menu .m3} msg] $msg [destroy .m1] +} {0 {} {}} + +test menu-12.1 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "active" + .m1 add command -label "test2" + .m1 add command -label "test3" + .m1 activate 2 + list [catch {.m1 entrycget active -label} msg] $msg [destroy .m1] +} {0 test2 {}} +test menu-12.2 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "last" + .m1 add command -label "test2" + .m1 add command -label "test3" + .m1 activate 2 + list [catch {.m1 entrycget last -label} msg] $msg [destroy .m1] +} {0 test3 {}} +test menu-12.3 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "last" + .m1 add command -label "test2" + .m1 add command -label "test3" + .m1 activate 2 + list [catch {.m1 entrycget end -label} msg] $msg [destroy .m1] +} {0 test3 {}} +test menu-12.4 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 insert last command -label "test2"} msg] $msg [.m1 entrycget last -label] [destroy .m1] +} {0 {} test2 {}} +test menu-12.5 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 insert end command -label "test2"} msg] $msg [.m1 entrycget end -label] [destroy .m1] +} {0 {} test2 {}} +test menu-12.6 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "active" + .m1 add command -label "test2" + .m1 add command -label "test3" + .m1 activate 2 + list [catch {.m1 entrycget none -label} msg] $msg [destroy .m1] +} {0 {} {}} +#test menu-13.7 - Need to add @test here. +test menu-12.7 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "active" + .m1 add command -label "test2" + .m1 add command -label "test3" + list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] +} {0 active {}} +test menu-12.8 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "active" + list [catch {.m1 entrycget -1 -label} msg] $msg [destroy .m1] +} {1 {bad menu entry index "-1"} {}} +test menu-12.9 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 add command -label "test2" + list [catch {.m1 entrycget 999 -label} msg] $msg [destroy .m1] +} {0 test2 {}} +test menu-12.10 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 insert 999 command -label "test" + list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] +} {0 test {}} +test menu-12.11 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "1test" + list [catch {.m1 entrycget 1test -label} msg] $msg [destroy .m1] +} {0 1test {}} +test menu-12.12 {TkGetMenuIndex} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 add command -label "test2" -command "beep" + .m1 add command -label "test3" + list [catch {.m1 entrycget test2 -command} msg] $msg [destroy .m1] +} {0 beep {}} + +test menu-13.1 {MenuCmdDeletedProc} { + catch {destroy .m1} + menu .m1 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-13.2 {MenuCmdDeletedProc} { + catch {destroy .m1} + menu .m1 + .m1 clone .m2 + list [catch {destroy .m1} msg] $msg +} {0 {}} + +test menu-14.1 {MenuNewEntry} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-14.2 {MenuNewEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 add command -label "test3" + list [catch {.m1 insert 2 command -label "test2"} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-14.3 {MenuNewEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 add command -label "test2"} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-14.4 {MenuNewEntry} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] +} {0 {} {}} + +test menu-15.1 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 insert foo command -label "test"} msg] $msg [destroy .m1] +} {1 {bad menu entry index "foo"} {}} +test menu-15.2 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 insert test command -label "foo"} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-15.3 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 insert -1 command -label "test"} msg] $msg [destroy .m1] +} {1 {bad menu entry index "-1"} {}} +test menu-15.4 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 insert 0 command -label "test2" + list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] +} {0 test2 {}} +test menu-15.5 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add cascade} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-15.6 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add checkbutton} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-15.7 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-15.8 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add radiobutton} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-15.9 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add separator} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-15.10 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add blork} msg] $msg [destroy .m1] +} {1 {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator} {}} +test menu-15.11 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-15.12 {MenuAddOrInsert} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + .m1 clone .m2 + .m2 clone .m3 + list [catch {.m2 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m3 entrycget 1 -label} msg3] $msg3 [destroy .m1] +} {0 {} 0 test 0 test {}} +test menu-15.13 {MenuAddOrInsert} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + .m1 clone .m2 + .m2 clone .m3 + list [catch {.m3 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m2 entrycget 1 -label} msg3] $msg3 [destroy .m1] +} {0 {} 0 test 0 test {}} +test menu-15.14 {MenuAddOrInsert} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -blork} msg] $msg [destroy .m1] +} {1 {unknown option "-blork"} {}} +test menu-15.15 {MenuAddOrInsert} { + catch {destroy .m1} + catch {destroy .container} + menu .m1 + .m1 add command -label "File" + menu .container + . configure -menu .container + list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .container .m1] +} {0 {} {} {}} +test menu-15.16 {MenuAddOrInsert} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + set tearoff [tkTearOffMenu .m2] + list [catch {.m2 add cascade -menu .m1} msg] $msg [$tearoff unpost] [catch {destroy .m1} msg2] $msg2 [catch {destroy .m2} msg3] $msg3 +} {0 {} {} 0 {} 0 {}} +test menu-15.17 {MenuAddOrInsert} { + catch {destroy .m1} + catch {destroy .container} + menu .m1 + menu .container + . configure -menu .container + set tearoff [tkTearOffMenu .container] + list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] +} {0 {} {} {}} +test menu-15.18 {MenuAddOrInsert} { + catch {destroy .m1} + catch {destroy .container} + menu .m1 + menu .container + .container add cascade -menu .m1 + . configure -menu .container + list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] +} {0 {} {} {}} +test menu-15.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { + catch {destroy .menubar} + menu .menubar + menu .menubar.test -tearoff 0 + .menubar add cascade -label Test -underline 0 -menu .menubar.test + menu .menubar.test.cascade -tearoff 0 + .menubar.test.cascade add command -label SubItem -command "puts SubItemSelected" + . configure -menu .menubar + list [catch {.menubar.test add cascade -label SubMenu \ + -menu .menubar.test.cascade} msg] \ + [info commands .\#menubar.\#menubar\#test.\#menubar\#test\#cascade] \ + [. configure -menu ""] [destroy .menubar] +} {0 .#menubar.#menubar#test.#menubar#test#cascade {} {}} + +test menu-16.1 {MenuVarProc} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + set foo "hello" + list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [catch {unset foo} msg2] $msg2 [destroy .m1] +} {0 {} 0 {} {}} +# menu-17.2 - Don't know how to generate the flags in the if +test menu-16.2 {MenuVarProc} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo ""] [destroy .m1] +} {0 {} {} {}} +test menu-16.3 {MenuVarProc} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + set foo "hello" + list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 +} {0 {} hello {} 0 {}} +test menu-16.4 {MenuVarProc} { + catch {destroy .m1} + menu .m1 + set foo "goodbye" + list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 +} {0 {} hello {} 0 {}} +test menu-16.5 {MenuVarProc} { + catch {destroy .m1} + menu .m1 + set foo "hello" + list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "goodbye"] [destroy .m1] [catch {unset foo} msg2] $msg2 +} {0 {} goodbye {} 0 {}} + +test menu-17.1 {TkActivateMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 activate 1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-17.2 {TkActivateMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [catch {.m1 activate 0} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-17.3 {TkActivateMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 add command -label "test2" + .m1 activate 1 + list [catch {.m1 activate 2} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-17.4 {TkActivateMenuEntry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 add command -label "test2" + .m1 activate 1 + list [catch {.m1 activate 1} msg] $msg [destroy .m1] +} {0 {} {}} + +test menu-18.1 {TkPostCommand} {menuInteractive} { + catch {destroy .m1} + menu .m1 -postcommand "set menu_test menu-19.1" + .m1 add command -label "menu-19.1 - hit Escape" + list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [set menu_test] [destroy .m1] +} {0 menu-19.1 {} menu-19.1 {}} +test menu-18.2 {TkPostCommand} {menuInteractive} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "menu-19.2 - hit Escape" + list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [destroy .m1] +} {0 {} {} {}} + +test menu-19.1 {CloneMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + list [catch {.m1 clone .m2} msg1] $msg1 [destroy .m1] +} {0 {} {}} +test menu-19.2 {CloneMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + list [catch {.m1 clone .m2 normal} msg1] $msg1 [destroy .m1] +} {0 {} {}} +test menu-19.3 {CloneMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + list [catch {.m1 clone .m2 tearoff} msg1] $msg1 [destroy .m1] +} {0 {} {}} +test menu-19.4 {CloneMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + list [catch {.m1 clone .m2 menubar} msg1] $msg1 [destroy .m1] +} {0 {} {}} +test menu-19.5 {CloneMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + list [catch {.m1 clone .m2 foo} msg1] $msg1 [destroy .m1] +} {1 {bad menu type - must be normal, tearoff, or menubar} {}} +test menu-19.6 {CloneMenu - hooking up bookeeping ptrs} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + list [catch {.m1 clone .m2} msg] $msg [destroy .m1] + } {0 {} {}} + test menu-19.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-19.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-19.9 {CloneMenu - cascades entries} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .foo} + menu .m1 + .m1 add cascade -menu .m2 + menu .m2 + list [catch {.m1 clone .foo} msg] $msg [destroy .m1 .m2] + } {0 {} {}} +test menu-19.10 {CloneMenu - tearoff fields} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + list [catch {.m1 clone .m2 normal} msg1] $msg1 [catch {.m2 cget -tearoff} msg2] $msg2 [destroy .m1] +} {0 {} 0 1 {}} +test menu-19.11 {CloneMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + menu .m2 + list [catch {.m1 clone .m2} msg] $msg [destroy .m1 .m2] +} {1 {window name "m2" already exists in parent} {}} + +test menu-20.1 {MenuDoYPosition} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 yposition glorp} msg] $msg [destroy .m1] +} {1 {bad menu entry index "glorp"} {}} +test menu-20.2 {MenuDoYPosition} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "Test" + list [catch {.m1 yposition 1}] [destroy .m1] +} {0 {}} + +test menu-21.1 {GetIndexFromCoords} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 configure -tearoff 0 + list [catch {.m1 index @5} msg] $msg [destroy .m1] +} {0 0 {}} +test menu-21.2 {GetIndexFromCoords} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 configure -tearoff 0 + list [catch {.m1 index @5,5} msg] $msg [destroy .m1] +} {0 0 {}} + +test menu-22.1 {RecursivelyDeleteMenu} { + catch {destroy .m1} + menu .m1 + . configure -menu .m1 + list [catch {. configure -menu ""} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-22.2 {RecursivelyDeleteMenu} { + catch {destroy .m1} + catch {destroy .m2} + menu .m2 + .m2 add command -label "test2" + menu .m1 + .m1 add cascade -label "test1" -menu .m2 + . configure -menu .m1 + list [catch {. configure -menu ""} msg] $msg [destroy .m1 .m2] +} {0 {} {}} + +test menu-23.1 {TkNewMenuName} { + catch {destroy .m1} + menu .m1 + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test menu-23.2 {TkNewMenuName} { + catch {destroy .m1} + catch {destroy .m1\#0} + menu .m1 + menu .m1\#0 + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test menu-23.3 {TkNewMenuName} { + catch {destroy .#m} + menu .#m + rename .#m hideme + list [catch {. configure -menu [menu .m]} $msg] [. configure -menu ""] [destroy .#m] [destroy .m] [destroy hideme] +} {0 {} {} {} {}} + +test menu-24.1 {TkSetWindowMenuBar} { + . configure -menu "" + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] +} {0 {} {}} +test menu-24.2 {TkSetWindowMenuBar} { + . configure -menu "" + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] +} {0 {} {}} +test menu-24.3 {TkSetWindowMenuBar} { + . configure -menu "" + catch {destroy .m1} + menu .m1 + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test menu-24.4 {TkSetWindowMenuBar} { + catch {destroy .m1} + catch {destroy .m2} + . configure -menu "" + menu .m1 + . configure -menu .m1 + menu .m2 + list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .m1 .m2] +} {0 {} {} {}} +test menu-24.5 {TkSetWindowMenuBar} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + . configure -menu "" + menu .m1 + . configure -menu .m1 + .m1 clone .m2 + menu .m3 + list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] +} {0 {} {} {}} +test menu-24.6 {TkSetWindowMenuBar} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + . configure -menu "" + menu .m1 + .m1 clone .m2 + . configure -menu .m2 + menu .m3 + list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] +} {0 {} {} {}} +test menu-24.7 {TkSetWindowMenuBar} { + catch {destroy .m1} + catch {destroy .m2} + . configure -menu "" + menu .m1 + menu .m2 + . configure -menu .m1 + toplevel .t2 + .t2 configure -menu .m1 + list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] +} {0 {} {} {}} +test menu-24.8 {TkSetWindowMenuBar} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .t2} + . configure -menu "" + menu .m1 + menu .m2 + . configure -menu .m1 + toplevel .t2 + wm geometry .t2 +0+0 + .t2 configure -menu .m1 + list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] +} {0 {} {} {}} +test menu-24.9 {TkSetWindowMenuBar} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .t2} + catch {destroy .t3} + . configure -menu "" + menu .m1 + menu .m2 + . configure -menu .m1 + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + toplevel .t3 -menu .m1 + wm geometry .t3 +0+0 + list [catch {.t3 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] +} {0 {} {} {}} +test menu-24.10 {TkSetWindowMenuBar} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .t2} + catch {destroy .t3} + . configure -menu "" + menu .m1 + menu .m2 + . configure -menu .m1 + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + toplevel .t3 -menu .m1 + wm geometry .t3 +0+0 + list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] +} {0 {} {} {}} +test menu-24.11 {TkSetWindowMenuBar} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .t2} + catch {destroy .t3} + . configure -menu "" + menu .m1 + menu .m2 + . configure -menu .m1 + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + toplevel .t3 -menu .m1 + wm geometry .t3 +0+0 + list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] +} {0 {} {} {}} +test menu-24.12 {TkSetWindowMenuBar} { + catch {destroy .m1} + . configure -menu "" + menu .m1 + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test menu-24.13 {TkSetWindowMenuBar} { + . configure -menu "" + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] +} {0 {} {}} +test menu-24.14 {TkSetWindowMenuBar} { + catch {destroy .m1} + . configure -menu "" + menu .m1 + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test menu-24.15 {TkSetWindowMenuBar} { + . configure -menu "" + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] +} {0 {} {}} +test menu-24.16 {TkSetWindowMenuBar} { + catch {destroy .m1} + . configure -menu "" + menu .m1 + . configure -menu .m1 + list [catch {toplevel .t2 -menu m1} msg] $msg [. configure -menu ""] [destroy .t2 .m1] +} {0 .t2 {} {}} + +test menu-25.1 {DestroyMenuHashTable} { + catch {interp destroy testinterp} + interp create testinterp + load {} Tk testinterp + interp eval testinterp {menu .m1} + list [catch {interp delete testinterp} msg] $msg +} {0 {}} + +test menu-26.1 {GetMenuHashTable} { + catch {interp destroy testinterp} + interp create testinterp + load {} tk testinterp + list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp] +} {0 .m1 {}} + +test menu-27.1 {TkCreateMenuReferences - not there before} { + catch {destroy .m1} + list [catch {menu .m1} msg] $msg [destroy .m1] +} {0 .m1 {}} +test menu-27.2 {TkCreateMenuReferences - there already} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add cascade -menu .m2 + list [catch {menu .m2} msg] $msg [destroy .m1 .m2] +} {0 .m2 {}} + +test menu-28.1 {TkFindMenuReferences - not there} { + catch {destroy .m1} + . configure -menu "" + menu .m1 + .m1 add cascade -menu .m2 + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test menu-29.1 {TkFindMenuReferences - there already} { + catch {destroy .m1} + catch {destroy .m2} + . configure -menu "" + menu .m1 + menu .m2 + .m1 add cascade -menu .m2 + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .m2] +} {0 {} {} {}} + +test menu-30.1 {TkFreeMenuReferences - menuPtr} { + catch {destroy .m1} + menu .m1 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test menu-30.2 {TkFreeMenuReferences - cascadePtr} { + catch {destroy .m1} + . configure -menu "" + menu .m1 + .m1 add cascade -menu .m2 + list [catch {.m1 entryconfigure 1 -menu .m3} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-30.3 {TkFreeMenuReferences - topLevelListPtr} { + . configure -menu .m1 + list [catch {. configure -menu ""} msg] $msg +} {0 {}} +test menu-30.4 {TkFreeMenuReferences - not empty} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add cascade -menu .m3 + menu .m2 + .m2 add cascade -menu .m3 + list [catch {.m2 entryconfigure 1 -menu ".foo"} msg] $msg [destroy .m1 .m2] +} {0 {} {}} + +test menu-31.1 {DeleteMenuCloneEntries} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add command -label foo + .m1 clone .m2 + list [catch {.m1 delete 1} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-31.2 {DeleteMenuCloneEntries} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add command -label one + .m1 add command -label two + .m1 add command -label three + .m1 add command -label four + .m1 clone .m2 + list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-31.3 {DeleteMenuCloneEntries} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 -tearoff 0 + .m1 add command -label one + .m1 add command -label two + .m1 add command -label three + .m1 add command -label four + .m1 clone .m2 + .m2 configure -tearoff 1 + list [catch {.m1 delete 1 2} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-31.4 {DeleteMenuCloneEntries} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add command -label one + .m1 add command -label two + .m1 add command -label three + .m1 add command -label four + .m1 clone .m2 + .m2 configure -tearoff 0 + list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-31.5 {DeleteMenuCloneEntries} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add command -label one + .m1 add command -label two + .m1 clone .m2 + .m1 activate one + list [catch {.m1 delete one} msg] $msg [destroy .m1] +} {0 {} {}} +test menu-31.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} { + catch {destroy .m1} + menu .m1 + .m1 add command -label test -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test" + list [catch {.m1 invoke test} msg] $msg [destroy .m1] +} {0 {} {}} + +set l [interp hidden] +eval destroy [winfo children .] + +test menu-32.1 {menu vs command hiding} { + catch {destroy .m} + menu .m + interp hide {} .m + destroy .m + list [winfo children .] [interp hidden] +} [list {} $l] + +# menu-34 MenuInit only called at boot time + +deleteWindows diff --git a/tests/menuDraw.test b/tests/menuDraw.test new file mode 100644 index 0000000..291d2a2 --- /dev/null +++ b/tests/menuDraw.test @@ -0,0 +1,546 @@ +# This file is a Tcl script to test drawing of menus in Tk. It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) menuDraw.test 1.11 97/06/24 13:50:34 + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +proc deleteWindows {} { + foreach i [winfo children .] { + catch [destroy $i] + } +} + +deleteWindows +wm geometry . {} +raise . + +if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} { + puts " Some tests were skipped because they could not be performed" + puts " automatically on this platform. If you wish to execute them" + puts " interactively, set the TCL variable INTERACTIVE and re-run" + puts " the test." + set testConfig(menuInteractive) 0 +} else { + set testConfig(menuInteractive) 1 +} + +test menuDraw-1.1 {TkMenuInitializeDrawingFields} { + catch {destroy .m1} + list [menu .m1] [destroy .m1] +} {.m1 {}} + +test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} { + catch {destroy .m1} + menu .m1 + list [.m1 add command] [destroy .m1] +} {{} {}} + +test menuDraw-3.1 {TkMenuFreeDrawOptions} { + catch {destroy .m1} + menu .m1 + list [destroy .m1] +} {{}} + +test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "This is a test" + list [destroy .m1] +} {{}} +test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label "This is a test." -font "Courier 12" -activeforeground red -background green -selectcolor purple + list [destroy .m1] +} {{}} + +test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} { + catch {destroy .m1} + list [menu .m1] [destroy .m1] +} {.m1 {}} +test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} { + catch {destroy .m1} + menu .m1 + list [.m1 configure -fg red] [destroy .m1] +} {{} {}} +test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} { + catch {destroy .m1} + list [menu .m1 -disabledforeground ""] [destroy .m1] +} {.m1 {}} + +test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} { + catch {destroy .m1} + menu .m1 + list [.m1 add command -label "foo"] [destroy .m1] +} {{} {}} +test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} { + catch {destroy .m1} + menu .m1 + list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1] +} {{} {}} +test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + list [.m1 entryconfigure 1 -state active] [destroy .m1] +} {{} {}} +test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + .m1 activate 1 + list [.m1 entryconfigure 1 -state active] [destroy .m1] +} {{} {}} +test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + .m1 activate 1 + list [.m1 entryconfigure 1 -state normal] [destroy .m1] +} {{} {}} +test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1] +} {1 {bad state value "foo": must be normal, active, or disabled} {}} +test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} { + catch {destroy .m1} + menu .m1 + list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1] +} {{} {}} +test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} { + catch {destroy .m1} + menu .m1 + list [.m1 add command -label "foo" -background "red"] [destroy .m1] +} {{} {}} +test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} { + catch {destroy .m1} + menu .m1 + list [.m1 add command -label "foo" -foreground "red"] [destroy .m1] +} {{} {}} +test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} { + catch {destroy .m1} + menu .m1 + list [.m1 add command -label "foo" -activebackground "red"] [destroy .m1] +} {{} {}} +test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} { + catch {destroy .m1} + menu .m1 + list [.m1 add command -label "foo" -activeforeground "red"] [destroy .m1] +} {{} {}} +test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} { + catch {destroy .m1} + menu .m1 + list [.m1 add radiobutton -label "foo" -selectcolor "red"] [destroy .m1] +} {{} {}} +test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" -font "Helvetica 12" + list [.m1 entryconfigure 1 -font "Courier 12"] [destroy .m1] +} {{} {}} +test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" -activeforeground "red" + list [.m1 entryconfigure 1 -activeforeground "green"] [destroy .m1] +} {{} {}} +test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} { + catch {destroy .m1} + menu .m1 -disabledforeground "red" + .m1 add command -label "foo" + list [.m1 configure -disabledforeground "green"] [destroy .m1] +} {{} {}} +test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -label "foo" -selectcolor "red" + list [.m1 entryconfigure 1 -selectcolor "green"] [destroy .m1] +} {{} {}} + +test menuDraw-7.1 {TkEventuallyRecomputeMenu} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "This is a long label" + set tearoff [tkTearOffMenu .m1] + update idletasks + list [.m1 entryconfigure 1 -label "foo"] [destroy .m1] +} {{} {}} +test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "This is a long label" + set tearoff [tkTearOffMenu .m1] + list [.m1 entryconfigure 1 -label "foo"] [destroy .m1] +} {{} {}} + + +test menuDraw-8.1 {TkRecomputeMenu} {menuInteractive} { + catch {destroy .m1} + menu .m1 + .m1 configure -postcommand [.m1 add command -label foo] + .m1 add command -label "Hit ESCAPE to make this menu go away." + list [.m1 post 0 0] [destroy .m1] +} {{} {}} + + +test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + set foo 0 + .m1 add radiobutton -variable foo -label test + tkTearOffMenu .m1 + update idletasks + list [set foo test] [destroy .m1] [unset foo] +} {test {} {}} +test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} { + catch {destroy .m1} + menu .m1 + list [catch {tkTearOffMenu .m1}] [destroy .m1] +} {0 {}} + +# Don't know how to test when window has been deleted and ComputeMenuGeometry +# gets called. +test menuDraw-10.1 {ComputeMenuGeometry - menubar} { + catch {destroy .m1} + menu .m1 + .m1 add command -label test + . configure -menu .m1 + list [update idletasks] [. configure -menu ""] [destroy .m1] +} {{} {} {}} +test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} { + catch {destroy .m1} + menu .m1 + .m1 add command -label test + list [update idletasks] [destroy .m1] +} {{} {}} +test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} { + catch {destroy .m1} + menu .m1 + .m1 add command -label test + list [update idletasks] [destroy .m1] +} {{} {}} +test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} { + catch {destroy .m1} + menu .m1 + .m1 add command -label test + update idletasks + .m1 entryconfigure 1 -label test + list [update idletasks] [destroy .m1] +} {{} {}} + +test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} { + 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 [tkTearOffMenu .m1 40 40] + update idletasks + list [image delete image2] [destroy .m1] [eval image delete [image names]] +} {{} {} {}} +test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} { + 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 [tkTearOffMenu .m1 40 40] + list [image delete image2] [destroy .m1] [eval image delete [image names]] +} {{} {} {}} +test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} { + 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 + set tearoff [tkTearOffMenu .m1 40 40] + update idletasks + list [image delete image2] [destroy .m1] [eval image delete [image names]] +} {{} {} {}} + +#Don't know how to test missing tkwin in DisplayMenu +test menuDraw-12.1 {DisplayMenu - menubar background} {unixOnly} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo -menu .m2 + . configure -menu .m1 + list [update] [. configure -menu ""] [destroy .m1] +} {{} {} {}} +test menuDraw-12.2 {Display menu - no entries} { + catch {destroy .m1} + menu .m1 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test menuDraw-12.3 {DisplayMenu - one entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test menuDraw-12.4 {DisplayMenu - two entries} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "one" + .m1 add command -label "two" + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test menuDraw.12.5 {DisplayMenu - two columns - first bigger} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "one" + .m1 add command -label "two" + .m1 add command -label "three" -columnbreak 1 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test menuDraw-12.5 {DisplayMenu - two column - second bigger} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "one" + .m1 add command -label "two" -columnbreak 1 + .m1 add command -label "three" + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test menuDraw.12.7 {DisplayMenu - three columns} { + catch {destroy .m1} + menu .m1 + .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" + .m1 add command -label "six" + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test menuDraw-12.6 {Display menu - testing for extra space and menubars} {unixOnly} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + . configure -menu .m1 + list [update] [. configure -menu ""] [destroy .m1] +} {{} {} {}} +test menuDraw-12.7 {Display menu - extra space at end of menu} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + set tearoff [tkTearOffMenu .m1 40 40] + wm geometry $tearoff 200x100 + list [update] [destroy .m1] +} {{} {}} + +test menuDraw-13.1 {TkMenuEventProc - Expose} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add command -label "one" + menu .m2 + .m2 add command -label "two" + set tearoff1 [tkTearOffMenu .m1 40 40] + set tearoff2 [tkTearOffMenu .m2 40 40] + list [raise $tearoff2] [update] [destroy .m1] [destroy .m2] +} {{} {} {} {}} +test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + set tearoff [tkTearOffMenu .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 + tkTearOffMenu .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. +test menuDraw-13.4 {TkMenuEventProc - simple delete} { + catch {destroy .m1} + menu .m1 + list [destroy .m1] +} {{}} +test menuDraw-13.5 {TkMenuEventProc - nothing pending} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + update idletasks + list [destroy .m1] +} {{}} + +test menuDraw-14.1 {TkMenuImageProc} { + catch {destroy .m1} + catch {image delete image1} + menu .m1 + image create test image1 + .m1 add command -image image1 + update idletasks + list [image delete image1] [destroy .m1] +} {{} {}} +test menuDraw-14.2 {TkMenuImageProc} { + catch {destroy .m1} + catch {image delete image1} + menu .m1 + image create test image1 + .m1 add command -image image1 + list [image delete image1] [destroy .m1] +} {{} {}} + +test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" -state active + set tearoff [tkTearOffMenu .m1 40 40] + list [$tearoff index active] [destroy .m1] +} {none {}} +test menuDraw-15.3 {TkPostTearoffMenu - post command} { + catch {destroy .m1} + catch {unset foo} + menu .m1 -postcommand "set foo .m1" + .m1 add command -label "foo" + list [catch {tkTearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1] +} {0 .m1 {} {}} +test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} { + catch {destroy .m1} + menu .m1 -postcommand "destroy .m1" + .m1 add command -label "foo" + list [catch {tkTearOffMenu .m1 40 40} msg] $msg [winfo exists .m1] +} {0 {} 0} +test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + set height [winfo screenheight .m1] + list [catch {tkTearOffMenu .m1 40 $height}] [destroy .m1] +} {0 {}} +test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "foo" + set width [winfo screenwidth .m1] + list [catch {tkTearOffMenu .m1 $width 40}] [destroy .m1] +} {0 {}} + + +test menuDraw-16.1 {TkPostSubmenu} {unixOnly} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add cascade -label test -menu .m2 + menu .m2 + .m2 add command -label "Hit ESCAPE to make this menu go away." + set tearoff [tkTearOffMenu .m1 40 40] + $tearoff postcascade 0 + list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] +} {{} {} {}} +test menuDraw-16.2 {TkPostSubMenu} {unixOnly} { + catch {destroy .m1} + catch {destroy .m2} + catch {destroy .m3} + menu .m1 + .m1 add cascade -label "two" -menu .m2 + .m1 add cascade -label "three" -menu .m3 + menu .m2 + .m2 add command -label "two" + menu .m3 + .m3 add command -label "three" + set tearoff [tkTearOffMenu .m1 40 40] + $tearoff postcascade 0 + list [$tearoff postcascade 1] [destroy .m1] [destroy .m2] [destroy .m3] +} {{} {} {} {}} +test menuDraw-16.3 {TkPostSubMenu} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label test -menu .m2 + list [.m1 postcascade 1] [destroy .m1] +} {{} {}} +test menuDraw-16.4 {TkPostSubMenu} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label test + set tearoff [tkTearOffMenu .m1 40 40] + list [$tearoff postcascade 0] [destroy .m1] +} {{} {}} +test menuDraw-16.5 {TkPostSubMenu} {unixOnly} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add cascade -label test -menu .m2 + menu .m2 -postcommand "glorp" + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2] +} {1 {invalid command name "glorp"} {} {}} +test menuDraw-16.6 {TkPostSubMenu} {menuInteractive} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add cascade -label test -menu .m2 + menu .m2 + .m2 add command -label "Hit ESCAPE to get rid of this menu" + set tearoff [tkTearOffMenu .m1 40 40] + list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] +} {{} {} {}} + +test menuDraw-17.1 {AdjustMenuCoords - menubar} {unixOnly} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 -tearoff 0 + .m1 add cascade -label test -menu .m2 + menu .m2 -tearoff 0 + .m2 add command -label foo + . configure -menu .m1 + foreach w [winfo children .] { + if {[$w cget -type] == "menubar"} { + break + } + } + list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2] +} {{} {} {} {}} +test menuDraw-17.2 {AdjustMenuCoords - menu} {menuInteractive} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add cascade -label test -menu .m2 + menu .m2 + .m2 add command -label "Hit ESCAPE to make this menu go away" + set tearoff [tkTearOffMenu .m1 40 40] + list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] +} {{} {} {}} + +deleteWindows diff --git a/tests/menubut.test b/tests/menubut.test new file mode 100644 index 0000000..8a5c14a --- /dev/null +++ b/tests/menubut.test @@ -0,0 +1,352 @@ +# This file is a Tcl script to test menubuttons in Tk. It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) menubut.test 1.26 97/07/31 10:08:50 + +# XXX This test file is woefully incomplete right now. If any part +# XXX of a procedure has tests then the whole procedure has tests, +# XXX but many procedures have no tests. + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Menubutton.borderWidth 2 +option add *Menubutton.highlightThickness 2 +option add *Menubutton.font {Helvetica -12 bold} +option add *Button.borderWidth 2 +option add *Button.highlightThickness 2 +option add *Button.font {Helvetica -12 bold} + +eval image delete [image names] +image create test image1 +menubutton .mb -text "Test" +pack .mb +update +set i 1 +foreach test { + {-activebackground #012345 #012345 non-existent + {unknown color name "non-existent"}} + {-activeforeground #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} + {-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"}} + {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-direction below below badValue {bad direction value "badValue": must be above, below, left, right, or flush}} + {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} + {-fg #110022 #110022 bogus {unknown color name "bogus"}} + {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} + {-foreground #110022 #110022 bogus {unknown color name "bogus"}} + {-height 18 18 20.0 {expected integer but got "20.0"}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} + {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} + {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} + {-image image1 image1 bogus {image "bogus" doesn't exist}} + {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}} + {-justify right right bogus {bad justification "bogus": must be left, right, or center}} + {-menu "any old string" "any old string" {} {}} + {-padx 12 12 420x {bad screen distance "420x"}} + {-pady 12 12 420x {bad screen distance "420x"}} + {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + {-state normal normal bogus {bad state value "bogus": must be normal, active, or disabled}} + {-takefocus "any string" "any string" {} {}} + {-text "Sample text" {Sample text} {} {}} + {-textvariable i i {} {}} + {-underline 5 5 3p {expected integer but got "3p"}} + {-width 402 402 3p {expected integer but got "3p"}} + {-wraplength 100 100 6x {bad screen distance "6x"}} +} { + set name [lindex $test 0] + test menubutton-1.$i {configuration options} { + .mb configure $name [lindex $test 1] + lindex [.mb configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test menubutton-1.$i {configuration options} { + list [catch {.mb configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .mb configure $name [lindex [.mb configure $name] 3] + incr i +} + +test menubutton-2.1 {Tk_MenubuttonCmd procedure} { + list [catch {menubutton} msg] $msg +} {1 {wrong # args: should be "menubutton pathName ?options?"}} +test menubutton-2.2 {Tk_MenubuttonCmd procedure} { + list [catch {menubutton foo} msg] $msg +} {1 {bad window path name "foo"}} +test menubutton-2.3 {Tk_MenubuttonCmd procedure} { + catch {destroy .mb} + menubutton .mb + winfo class .mb +} {Menubutton} +test menubutton-2.4 {Tk_ButtonCmd procedure} { + catch {destroy .mb} + list [catch {menubutton .mb -gorp foo} msg] $msg [winfo exists .mb] +} {1 {unknown option "-gorp"} 0} + +catch {destroy .mb} +menubutton .mb -text "Test Menu" +pack .mb +test menubutton-3.1 {MenuButtonWidgetCmd procedure} { + list [catch {.mb} msg] $msg +} {1 {wrong # args: should be ".mb option ?arg arg ...?"}} +test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.mb c} msg] $msg +} {1 {bad option "c": must be cget or configure}} +test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.mb cget} msg] $msg +} {1 {wrong # args: should be ".mb cget option"}} +test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.mb cget a b} msg] $msg +} {1 {wrong # args: should be ".mb cget option"}} +test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.mb cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} { + .mb configure -highlightthickness 3 + .mb cget -highlightthickness +} {3} +test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} { + llength [.mb configure] +} {32} +test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.mb configure -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.mb co -bg #ffffff -fg} msg] $msg +} {1 {value for "-fg" missing}} +test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} { + .mb configure -fg #123456 + .mb configure -bg #654321 + lindex [.mb configure -fg] 4 +} {#123456} +test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.mb foobar} msg] $msg +} {1 {bad option "foobar": must be cget or configure}} + +# XXX Need to add tests for several procedures here. The tests for XXX +# XXX ConfigureMenuButton aren't complete either. XXX + +test menubutton-4.1 {ConfigureMenuButton procedure} { + catch {destroy .mb1} + button .mb1 -text "Menubutton 1" + list [catch {.mb1 configure -width 1i} msg] $msg $errorInfo +} {1 {expected integer but got "1i"} {expected integer but got "1i" + (processing -width option) + invoked from within +".mb1 configure -width 1i"}} +test menubutton-4.2 {ConfigureMenuButton procedure} { + catch {destroy .mb1} + button .mb1 -text "Menubutton 1" + list [catch {.mb1 configure -height 0.5c} msg] $msg $errorInfo +} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c" + (processing -height option) + invoked from within +".mb1 configure -height 0.5c"}} +test menubutton-4.3 {ConfigureMenuButton procedure} { + catch {destroy .mb1} + button .mb1 -bitmap questhead + list [catch {.mb1 configure -width abc} msg] $msg $errorInfo +} {1 {bad screen distance "abc"} {bad screen distance "abc" + (processing -width option) + invoked from within +".mb1 configure -width abc"}} +test menubutton-4.4 {ConfigureMenuButton procedure} { + catch {destroy .mb1} + eval image delete [image names] + image create test image1 + button .mb1 -image image1 + list [catch {.mb1 configure -height 0.5x} msg] $msg $errorInfo +} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x" + (processing -height option) + invoked from within +".mb1 configure -height 0.5x"}} +test menubutton-4.5 {ConfigureMenuButton procedure} {fonts} { + catch {destroy .mb1} + button .mb1 -text "Sample text" -width 10 -height 2 + pack .mb1 + set result "[winfo reqwidth .mb1] [winfo reqheight .mb1]" + .mb1 configure -bitmap questhead + lappend result [winfo reqwidth .mb1] [winfo reqheight .mb1] +} {102 46 20 12} +test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} { + catch {destroy .mb} + menubutton .mb -text "Test" + list [catch {.mb configure -direction badValue} msg] $msg \ + [.mb cget -direction] [destroy .mb] +} {1 {bad direction value "badValue": must be above, below, left, right, or flush} below {}} + +# XXX Need to add tests for several procedures here. XXX + +test menubutton-5.1 {MenuButtonEventProc procedure} { + eval destroy [winfo children .] + menubutton .mb1 -bg #543210 + rename .mb1 .mb2 + set x {} + lappend x [winfo children .] + lappend x [.mb2 cget -bg] + destroy .mb1 + lappend x [info command .mb*] [winfo children .] +} {.mb1 #543210 {} {}} + +test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} { + eval destroy [winfo children .] + menubutton .mb1 + rename .mb1 {} + list [info command .mb*] [winfo children .] +} {{} {}} + +test menubutton-7.1 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 4 -highlightthickness 0 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {38 23} +test menubutton-7.2 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 1 -highlightthickness 2 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {36 21} +test menubutton-7.3 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {34 19} +test menubutton-7.4 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 2 -relief raised -width 40 \ + -highlightthickness 2 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {48 23} +test menubutton-7.5 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 2 -relief raised -height 30 \ + -highlightthickness 2 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {38 38} +test menubutton-7.6 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -bitmap question -bd 2 -relief raised \ + -highlightthickness 2 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {25 35} +test menubutton-7.7 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \ + -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {46 33} +test menubutton-7.8 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \ + -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {23 56} +test menubutton-7.9 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \ + -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {42 20} +test menubutton-7.10 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised -width 20 \ + -padx 0 -pady 0 -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {146 20} +test menubutton-7.11 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised -height 2 \ + -padx 0 -pady 0 -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {42 34} +test menubutton-7.12 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \ + -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {62 30} +test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised \ + -highlightthickness 1 -indicatoron 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {78 28} +test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {unix nonPortable} { + # The following test is non-portable because the indicator's pixel + # size varies to maintain constant absolute size. + + catch {destroy .mb} + menubutton .mb -image image1 -bd 2 -relief raised \ + -highlightthickness 2 -indicatoron 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {64 23} +test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {pc nonPortable} { + # The following test is non-portable because the indicator's pixel + # size varies to maintain constant absolute size. + + catch {destroy .mb} + menubutton .mb -image image1 -bd 2 -relief raised \ + -highlightthickness 2 -indicatoron 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {65 23} + +set l [interp hidden] +eval destroy [winfo children .] + +test menubutton-8.1 {menubutton vs hidden commands} { + catch {destroy .mb} + menubutton .mb + interp hide {} .mb + destroy .mb + list [winfo children .] [interp hidden] +} [list {} $l] + +eval image delete [image names] +eval destroy [winfo children .] +option clear + diff --git a/tests/msgbox.test b/tests/msgbox.test new file mode 100644 index 0000000..c23ddaf --- /dev/null +++ b/tests/msgbox.test @@ -0,0 +1,157 @@ +# This file is a Tcl script to test out Tk's "tk_messageBox" command. +# It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) msgbox.test 1.7 97/07/31 10:05:25 +# + +if {[string compare test [info procs test]] == 1} { + source defs +} + +test msgbox-1.1 {tk_messageBox command} { + list [catch {tk_messageBox -foo} msg] $msg +} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}} +test msgbox-1.2 {tk_messageBox command} { + list [catch {tk_messageBox -foo bar} msg] $msg +} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}} + +catch {tk_messageBox -foo bar} msg +regsub -all , $msg "" options +regsub \"-foo\" $options "" options + +foreach option $options { + if {[string index $option 0] == "-"} { + test msgbox-1.3 {tk_messageBox command} { + list [catch {tk_messageBox $option} msg] $msg + } [list 1 "value for \"$option\" missing"] + } +} + +test msgbox-1.4 {tk_messageBox command} { + list [catch {tk_messageBox -default} msg] $msg +} {1 {value for "-default" missing}} + +test msgbox-1.5 {tk_messageBox command} { + list [catch {tk_messageBox -type foo} msg] $msg +} {1 {invalid message box type "foo", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel}} + +test msgbox-1.6 {tk_messageBox command} { + list [catch {tk_messageBox -default 1.1} msg] $msg +} {1 {invalid default button "1.1"}} + +test msgbox-1.7 {tk_messageBox command} { + list [catch {tk_messageBox -default foo} msg] $msg +} {1 {invalid default button "foo"}} + +test msgbox-1.8 {tk_messageBox command} { + list [catch {tk_messageBox -type yesno -default 3} msg] $msg +} {1 {invalid default button "3"}} + +test msgbox-1.9 {tk_messageBox command} { + list [catch {tk_messageBox -icon foo} msg] $msg +} {1 {invalid icon "foo", must be error, info, question or warning}} + +test msgbox-1.10 {tk_messageBox command} { + list [catch {tk_messageBox -parent foo.bar} msg] $msg +} {1 {bad window path name "foo.bar"}} + +if {[info commands tkMessageBox] == ""} { + set isNative 1 +} else { + set isNative 0 +} + +if {$isNative && ![info exists INTERACTIVE]} { + puts " Some tests were skipped because they could not be performed" + puts " automatically on this platform. If you wish to execute them" + puts " interactively, set the TCL variable INTERACTIVE and re-run" + puts " the test" + return +} + +proc ChooseMsg {parent btn} { + global isNative + if {!$isNative} { + after 100 SendEventToMsg $parent $btn mouse + } +} + +proc ChooseMsgByKey {parent btn} { + global isNative + if {!$isNative} { + after 100 SendEventToMsg $parent $btn key + } +} + +proc PressButton {btn} { + event generate $btn <Enter> + event generate $btn <ButtonPress-1> -x 5 -y 5 + event generate $btn <ButtonRelease-1> -x 5 -y 5 +} + +proc SendEventToMsg {parent btn type} { + if {$parent != "."} { + set w $parent.__tk__messagebox + } else { + set w .__tk__messagebox + } + if ![winfo ismapped $w.$btn] { + update + } + if {$type == "mouse"} { + PressButton $w.$btn + } else { + event generate $w <Enter> + focus $w + event generate $w.$btn <Enter> + event generate $w <KeyPress> -keysym Return + } +} + +set parent . + +set specs { + {"abortretryignore" MB_ABORTRETRYIGNORE 3 {"abort" "retry" "ignore"}} + {"ok" MB_OK 1 {"ok" }} + {"okcancel" MB_OKCANCEL 2 {"ok" "cancel" }} + {"retrycancel" MB_RETRYCANCEL 2 {"retry" "cancel" }} + {"yesno" MB_YESNO 2 {"yes" "no" }} + {"yesnocancel" MB_YESNOCANCEL 3 {"yes" "no" "cancel"}} +} + +# +# Try out all combinations of (type) x (default button) and +# (type) x (icon). +# +foreach spec $specs { + set type [lindex $spec 0] + set buttons [lindex $spec 3] + + set button [lindex $buttons 0] + test msgbox-2.1 {tk_messageBox command} { + ChooseMsg $parent $button + tk_messageBox -title Hi -message "Please press $button" \ + -type $type + } $button + + foreach icon {warning error info question} { + test msgbox-2.2 {tk_messageBox command -icon option} { + ChooseMsg $parent $button + tk_messageBox -title Hi -message "Please press $button" \ + -type $type -icon $icon + } $button + } + + foreach button $buttons { + test msgbox-2.3 {tk_messageBox command} { + ChooseMsg $parent $button + tk_messageBox -title Hi -message "Please press $button" \ + -type $type -default $button + } "$button" + } +} diff --git a/tests/oldpack.test b/tests/oldpack.test new file mode 100644 index 0000000..a63eaef --- /dev/null +++ b/tests/oldpack.test @@ -0,0 +1,508 @@ +# This file is a Tcl script to test out the old syntax of Tk's +# "pack" command (before release 3.3). It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) oldpack.test 1.10 97/06/24 13:32:16 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +# First, test a single window packed in various ways in a parent + +catch {destroy .pack} +frame .pack +place .pack -width 100 -height 100 +frame .pack.red -width 10 -height 20 +label .pack.red.l -text R -bd 2 -relief raised +place .pack.red.l -relwidth 1.0 -relheight 1.0 +frame .pack.green -width 30 -height 40 +label .pack.green.l -text G -bd 2 -relief raised +place .pack.green.l -relwidth 1.0 -relheight 1.0 +frame .pack.blue -width 40 -height 40 +label .pack.blue.l -text B -bd 2 -relief raised +place .pack.blue.l -relwidth 1.0 -relheight 1.0 +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} { + pack ap .pack .pack.red top + update + winfo geometry .pack.red +} 10x20+45+0 +test pack-1.2 {basic positioning} { + pack append .pack .pack.red bottom + update + winfo geometry .pack.red +} 10x20+45+80 +test pack-1.3 {basic positioning} { + pack append .pack .pack.red left + update + winfo geometry .pack.red +} 10x20+0+40 +test pack-1.4 {basic positioning} { + pack append .pack .pack.red right + update + winfo geometry .pack.red +} 10x20+90+40 + +# Try adding padding around the window and make sure that the +# window gets a larger frame. + +test pack-2.1 {padding} { + pack append .pack .pack.red {t padx 20} + update + winfo geometry .pack.red +} 10x20+45+0 +test pack-2.2 {padding} { + pack append .pack .pack.red {top pady 20} + update + winfo geometry .pack.red +} 10x20+45+10 +test pack-2.3 {padding} { + pack append .pack .pack.red {l padx 20} + update + winfo geometry .pack.red +} 10x20+10+40 +test pack-2.4 {padding} { + pack append .pack .pack.red {left pady 20} + update + winfo geometry .pack.red +} 10x20+0+40 + +# Position the window at different positions in its frame to +# 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} { + pack append .pack .pack.red {b padx 20 pady 30} + update + winfo geometry .pack.red +} 10x20+45+65 +test pack-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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + pack append .pack .pack.red {r padx 20 pady 30} + update + winfo geometry .pack.red +} 10x20+80+40 +test pack-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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + pack append .pack .pack.red {right padx 20 pady 30 frame center} + update + winfo geometry .pack.red +} 10x20+80+40 + +# Try out various filling combinations in a couple of different +# frame locations. + +test pack-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} { + pack append .pack .pack.red {bottom padx 20 pady 30 filly} + update + winfo geometry .pack.red +} 10x50+45+50 +test pack-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} { + pack append .pack .pack.red {right padx 20 pady 30 fillx} + update + winfo geometry .pack.red +} 30x20+70+40 +test pack-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} { + pack append .pack .pack.red {right padx 20 pady 30 fill} + update + winfo geometry .pack.red +} 30x100+70+0 + +# Multiple windows: make sure that space is properly subtracted +# from the cavity as windows are positioned inwards from all +# different sides. Also make sure that windows get unmapped if +# there isn't enough space for them. + +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 +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 +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 +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 +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 +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 +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 +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 the ability of the packer to propagate geometry information +# to its parent. Make sure it computes the parent's needs both in +# the direction of packing (width for "left" and "right" windows, +# for example), and perpendicular to the pack direction (height for +# "left" and "right" windows). + +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 +destroy .pack.violet +update +test pack-6.3 {geometry propagation} {winfo reqwidth .pack} 40 +test pack-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 +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 the "expand" option, and make sure space is evenly divided +# when several windows request expansion. + +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} { + 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} { + 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} { + foreach i [winfo child .pack] { + pack unpack $i + } + pack append .pack .pack.green {left e fill} .pack.red {left expand fill} \ + .pack.blue {top fill} + update + 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} { + foreach i [winfo child .pack] { + pack unpack $i + } + pack append .pack .pack.red {top expand} .pack.violet {top expand} \ + .pack.blue {right fill} + update + 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} { + foreach i [winfo child .pack] { + pack unpack $i + } + pack append .pack .pack.green {right frame s} .pack.red {top expand} + update + list [winfo geometry .pack.green] [winfo geometry .pack.red] +} {30x40+70+60 10x20+30+40} +test pack-7.6 {multiple expanded windows} { + foreach i [winfo child .pack] { + pack unpack $i + } + pack append .pack .pack.violet {bottom frame e} .pack.red {right expand} + update + list [winfo geometry .pack.violet] [winfo geometry .pack.red] +} {80x20+20+80 10x20+45+30} + +# Need more bizarre tests with combinations of expanded windows and +# windows in opposing directions! Also, include padding in expanded +# (and unexpanded) windows. + +# Syntax errors on pack commands + +test pack-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} { + 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} { + 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} { + 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} { + set msg "" + set result [catch {pack after foobar} msg] + concat $result $msg +} {1 bad window path name "foobar"} +test pack-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} { + set msg "" + set result [catch {pack append foobar} msg] + concat $result $msg +} {1 bad window path name "foobar"} +test pack-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} { + 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} { + 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} { + set msg "" + set result [catch {pack info foobar} msg] + concat $result $msg +} {1 bad window path name "foobar"} +test pack-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} { + 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} { + 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} { + 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} { + set msg "" + set result [catch {pack append .pack .pack.blue {frame south}} msg] + concat $result $msg +} {1 bad anchor position "south": must be n, ne, e, se, s, sw, w, nw, or center} +test pack-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} { + 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} { + 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} { + 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} { + 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} { + set msg "" + set result [catch {pack append .pack .pack.blue frame} msg] + concat $result $msg +} {1 wrong # args: "frame" option must be followed by anchor point} + +# Test "pack info" command output. + +test pack-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} { + 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} { + 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] \ + [pack info .pack.green] [pack info .pack.violet] +} {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}} + +catch {destroy .pack} +concat {} diff --git a/tests/option.test b/tests/option.test new file mode 100644 index 0000000..aad9197 --- /dev/null +++ b/tests/option.test @@ -0,0 +1,232 @@ +# This file is a Tcl script to test out the option-handling facilities +# of Tk. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) option.test 1.20 97/08/07 15:54:37 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +catch {destroy .op1} +catch {destroy .op2} +set appName [winfo name .] + +# First, test basic retrievals, being sure to trigger all the various +# types of NodeElements (EXACT_LEAF_NAME, WILDCARD_NODE_CLASS, and +# everything in-between). + +frame .op1 -class Class1 +frame .op2 -class Class2 +frame .op1.op3 -class Class1 +frame .op1.op4 -class Class3 +frame .op2.op5 -class Class2 +frame .op1.op3.op6 -class Class4 + +option clear +option add *Color1 red +option add *x blue +option add *Class1.x yellow +option add $appName.op1.x green +option add *Class2.Color1 orange +option add $appName.op2.op5.Color2 purple +option add $appName.Class1.Class3.y brown +option add $appName*op6*Color2 black +option add $appName*Class1.op1.Color2 grey + +test option-1.1 {basic option retrieval} {option get . x Color1} blue +test option-1.2 {basic option retrieval} {option get . y Color1} red +test option-1.3 {basic option retrieval} {option get . z Color1} red +test option-1.4 {basic option retrieval} {option get . x Color2} blue +test option-1.5 {basic option retrieval} {option get . y Color2} {} +test option-1.6 {basic option retrieval} {option get . z Color2} {} + +test option-2.1 {basic option retrieval} {option get .op1 x Color1} green +test option-2.2 {basic option retrieval} {option get .op1 y Color1} red +test option-2.3 {basic option retrieval} {option get .op1 z Color1} red +test option-2.4 {basic option retrieval} {option get .op1 x Color2} green +test option-2.5 {basic option retrieval} {option get .op1 y Color2} {} +test option-2.6 {basic option retrieval} {option get .op1 z Color2} {} + +test option-3.1 {basic option retrieval} {option get .op1.op3 x Color1} yellow +test option-3.2 {basic option retrieval} {option get .op1.op3 y Color1} red +test option-3.3 {basic option retrieval} {option get .op1.op3 z Color1} red +test option-3.4 {basic option retrieval} {option get .op1.op3 x Color2} yellow +test option-3.5 {basic option retrieval} {option get .op1.op3 y Color2} {} +test option-3.6 {basic option retrieval} {option get .op1.op3 z Color2} {} + +test option-4.1 {basic option retrieval} {option get .op1.op3.op6 x Color1} blue +test option-4.2 {basic option retrieval} {option get .op1.op3.op6 y Color1} red +test option-4.3 {basic option retrieval} {option get .op1.op3.op6 z Color1} red +test option-4.4 {basic option retrieval} {option get .op1.op3.op6 x Color2} black +test option-4.5 {basic option retrieval} {option get .op1.op3.op6 y Color2} black +test option-4.6 {basic option retrieval} {option get .op1.op3.op6 z Color2} black + +test option-5.1 {basic option retrieval} {option get .op1.op4 x Color1} blue +test option-5.2 {basic option retrieval} {option get .op1.op4 y Color1} brown +test option-5.3 {basic option retrieval} {option get .op1.op4 z Color1} red +test option-5.4 {basic option retrieval} {option get .op1.op4 x Color2} blue +test option-5.5 {basic option retrieval} {option get .op1.op4 y Color2} brown +test option-5.6 {basic option retrieval} {option get .op1.op4 z Color2} {} + +test option-6.1 {basic option retrieval} {option get .op2 x Color1} orange +test option-6.2 {basic option retrieval} {option get .op2 y Color1} orange +test option-6.3 {basic option retrieval} {option get .op2 z Color1} orange +test option-6.4 {basic option retrieval} {option get .op2 x Color2} blue +test option-6.5 {basic option retrieval} {option get .op2 y Color2} {} +test option-6.6 {basic option retrieval} {option get .op2 z Color2} {} + +test option-7.1 {basic option retrieval} {option get .op2.op5 x Color1} orange +test option-7.2 {basic option retrieval} {option get .op2.op5 y Color1} orange +test option-7.3 {basic option retrieval} {option get .op2.op5 z Color1} orange +test option-7.4 {basic option retrieval} {option get .op2.op5 x Color2} purple +test option-7.5 {basic option retrieval} {option get .op2.op5 y Color2} purple +test option-7.6 {basic option retrieval} {option get .op2.op5 z Color2} purple + +# Now try similar tests to above, except jump around non-hierarchically +# between windows to make sure that the option stacks are pushed and +# popped correctly. + +option get . foo Foo +test option-8.1 {stack pushing/popping} {option get .op2.op5 x Color1} orange +test option-8.2 {stack pushing/popping} {option get .op2.op5 y Color1} orange +test option-8.3 {stack pushing/popping} {option get .op2.op5 z Color1} orange +test option-8.4 {stack pushing/popping} {option get .op2.op5 x Color2} purple +test option-8.5 {stack pushing/popping} {option get .op2.op5 y Color2} purple +test option-8.6 {stack pushing/popping} {option get .op2.op5 z Color2} purple + +test option-9.1 {stack pushing/popping} {option get . x Color1} blue +test option-9.2 {stack pushing/popping} {option get . y Color1} red +test option-9.3 {stack pushing/popping} {option get . z Color1} red +test option-9.4 {stack pushing/popping} {option get . x Color2} blue +test option-9.5 {stack pushing/popping} {option get . y Color2} {} +test option-9.6 {stack pushing/popping} {option get . z Color2} {} + +test option-10.1 {stack pushing/popping} {option get .op1.op3.op6 x Color1} blue +test option-10.2 {stack pushing/popping} {option get .op1.op3.op6 y Color1} red +test option-10.3 {stack pushing/popping} {option get .op1.op3.op6 z Color1} red +test option-10.4 {stack pushing/popping} {option get .op1.op3.op6 x Color2} black +test option-10.5 {stack pushing/popping} {option get .op1.op3.op6 y Color2} black +test option-10.6 {stack pushing/popping} {option get .op1.op3.op6 z Color2} black + +test option-11.1 {stack pushing/popping} {option get .op1.op3 x Color1} yellow +test option-11.2 {stack pushing/popping} {option get .op1.op3 y Color1} red +test option-11.3 {stack pushing/popping} {option get .op1.op3 z Color1} red +test option-11.4 {stack pushing/popping} {option get .op1.op3 x Color2} yellow +test option-11.5 {stack pushing/popping} {option get .op1.op3 y Color2} {} +test option-11.6 {stack pushing/popping} {option get .op1.op3 z Color2} {} + +test option-12.1 {stack pushing/popping} {option get .op1 x Color1} green +test option-12.2 {stack pushing/popping} {option get .op1 y Color1} red +test option-12.3 {stack pushing/popping} {option get .op1 z Color1} red +test option-12.4 {stack pushing/popping} {option get .op1 x Color2} green +test option-12.5 {stack pushing/popping} {option get .op1 y Color2} {} +test option-12.6 {stack pushing/popping} {option get .op1 z Color2} {} + +# Test the major priority levels (widgetDefault, etc.) + +option add $appName.op1.a 100 100 +option add $appName.op1.A interactive interactive +option add $appName.op1.b userDefault userDefault +option add $appName.op1.B startupFile startupFile +option add $appName.op1.c widgetDefault widgetDefault +option add $appName.op1.C 0 0 + +test option-13.1 {priority levels} {option get .op1 a A} 100 +test option-13.2 {priority levels} {option get .op1 b A} interactive +test option-13.3 {priority levels} {option get .op1 b B} userDefault +test option-13.4 {priority levels} {option get .op1 c B} startupFile +test option-13.5 {priority levels} {option get .op1 c C} widgetDefault +option add $appName.op1.B file2 widget +test option-13.6 {priority levels} {option get .op1 c B} startupFile +option add $appName.op1.B file2 startupFile +test option-13.7 {priority levels} {option get .op1 c B} file2 + +# Test various error conditions + +test option-14.1 {error conditions} { + list [catch {option} msg] $msg +} {1 {wrong # args: should be "option cmd arg ?arg ...?"}} +test option-14.2 {error conditions} { + list [catch {option x} msg] $msg +} {1 {bad option "x": must be add, clear, get, or readfile}} +test option-14.3 {error conditions} { + list [catch {option foo 3} msg] $msg +} {1 {bad option "foo": must be add, clear, get, or readfile}} +test option-14.4 {error conditions} { + list [catch {option add 3} msg] $msg +} {1 {wrong # args: should be "option add pattern value ?priority?"}} +test option-14.5 {error conditions} { + list [catch {option add . a b c} msg] $msg +} {1 {wrong # args: should be "option add pattern value ?priority?"}} +test option-14.6 {error conditions} { + list [catch {option add . a -1} msg] $msg +} {1 {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}} +test option-14.7 {error conditions} { + list [catch {option add . a 101} msg] $msg +} {1 {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}} +test option-14.8 {error conditions} { + list [catch {option add . a gorp} msg] $msg +} {1 {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}} +test option-14.9 {error conditions} { + list [catch {option get 3} msg] $msg +} {1 {wrong # args: should be "option get window name class"}} +test option-14.10 {error conditions} { + list [catch {option get 3 4} msg] $msg +} {1 {wrong # args: should be "option get window name class"}} +test option-14.11 {error conditions} { + list [catch {option get 3 4 5 6} msg] $msg +} {1 {wrong # args: should be "option get window name class"}} +test option-14.12 {error conditions} { + list [catch {option get .gorp.gorp a A} msg] $msg +} {1 {bad window path name ".gorp.gorp"}} + +if {$tcl_platform(os) == "Win32s"} { + set option1 OPTION~2.FIL + set option2 OPTION~1.FIL + set option3 OPTION~3.FIL +} else { + set option1 option.file1 + set option2 option.file2 + set option3 option.file3 +} + +test option-15.1 {database files} { + list [catch {option read non-existent} msg] $msg +} {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.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} {} +test option-15.7 {database files} { + list [catch {option read $option1 widget foo} msg] $msg +} {1 {wrong # args: should be "option readfile fileName ?priority?"}} +option add *x3 burgundy +catch {option read $option1 userDefault} +test option-15.8 {database files} {option get . x3 color} burgundy +test option-15.9 {database files} { + list [catch {option read $option2} msg] $msg +} {1 {missing colon on line 2}} + +test option-16.1 {ReadOptionFile} { + set file [open "$option3" w] + fconfigure $file -translation crlf + puts $file "*x7: true\n*x8: false" + close $file + option read $option3 userDefault + set result [list [option get . x7 color] [option get . x8 color]] + removeFile $option3 + set result +} {true false} + +catch {destroy .op1} +catch {destroy .op2} +concat {} diff --git a/tests/pack.test b/tests/pack.test new file mode 100644 index 0000000..3443d74 --- /dev/null +++ b/tests/pack.test @@ -0,0 +1,969 @@ +# This file is a Tcl script to test out the "pack" command +# of Tk. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) pack.test 1.27 97/07/01 18:06:56 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +# Utility procedures: + +proc pack1 {args} { + pack forget .pack.a .pack.b .pack.c .pack.d + eval pack .pack.a $args + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} +proc pack2 {args} { + pack forget .pack.a .pack.b .pack.c .pack.d + eval pack .pack.a $args + update + winfo geometry .pack.a +} +proc pack3 {args} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side top + pack .pack.c -side left + eval pack .pack.b $args + update + winfo geometry .pack.b +} +proc pack4 {option value} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a $option $value + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i $option]+1] +} + +# Create some test windows. + +catch {destroy .pack} +toplevel .pack +wm geom .pack 300x200+0+0 +wm minsize .pack 1 1 +update idletasks +foreach i {a b c d} { + frame .pack.$i + label .pack.$i.label -text $i -relief raised + place .pack.$i.label -relwidth 1.0 -relheight 1.0 +} +.pack.a config -width 20 -height 40 +.pack.b config -width 50 -height 30 +.pack.c config -width 80 -height 80 +.pack.d config -width 40 -height 30 + +test pack-1.1 {-side option} { + pack1 -side top +} {20x40+140+0 300x160+0+40} +test pack-1.2 {-side option} { + pack1 -side bottom +} {20x40+140+160 300x160+0+0} +test pack-1.3 {-side option} { + pack1 -side left +} {20x40+0+80 280x200+20+0} +test pack-1.4 {-side option} { + pack1 -side right +} {20x40+280+80 280x200+0+0} + +test pack-2.1 {x padding and filling} { + pack1 -side right -padx 20 +} {20x40+260+80 240x200+0+0} +test pack-2.2 {x padding and filling} { + pack1 -side right -ipadx 20 +} {60x40+240+80 240x200+0+0} +test pack-2.3 {x padding and filling} { + pack1 -side right -ipadx 5 -padx 10 +} {30x40+260+80 250x200+0+0} +test pack-2.4 {x padding and filling} { + pack1 -side right -padx 20 -fill x +} {20x40+260+80 240x200+0+0} +test pack-2.5 {x padding and filling} { + pack1 -side right -ipadx 20 -fill x +} {60x40+240+80 240x200+0+0} +test pack-2.6 {x padding and filling} { + pack1 -side right -ipadx 5 -padx 10 -fill x +} {30x40+260+80 250x200+0+0} +test pack-2.7 {x padding and filling} { + pack1 -side top -padx 20 +} {20x40+140+0 300x160+0+40} +test pack-2.8 {x padding and filling} { + pack1 -side top -ipadx 20 +} {60x40+120+0 300x160+0+40} +test pack-2.9 {x padding and filling} { + pack1 -side top -ipadx 5 -padx 10 +} {30x40+135+0 300x160+0+40} +test pack-2.10 {x padding and filling} { + pack1 -side top -padx 20 -fill x +} {260x40+20+0 300x160+0+40} +test pack-2.11 {x padding and filling} { + pack1 -side top -ipadx 20 -fill x +} {300x40+0+0 300x160+0+40} +test pack-2.12 {x padding and filling} { + pack1 -side top -ipadx 5 -padx 10 -fill x +} {280x40+10+0 300x160+0+40} +set pad [winfo pixels .pack 1c] +test pack-2.13 {x padding and filling} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -padx 1c + set x [pack info .pack.a] + lindex $x [expr [lsearch -exact $x -padx]+1] +} $pad +test pack-2.14 {x padding and filling} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -ipadx 1c + set x [pack info .pack.a] + lindex $x [expr [lsearch -exact $x -ipadx]+1] +} $pad + +test pack-3.1 {y padding and filling} { + pack1 -side right -pady 20 +} {20x40+280+80 280x200+0+0} +test pack-3.2 {y padding and filling} { + pack1 -side right -ipady 20 +} {20x80+280+60 280x200+0+0} +test pack-3.3 {y padding and filling} { + pack1 -side right -ipady 5 -pady 10 +} {20x50+280+75 280x200+0+0} +test pack-3.4 {y padding and filling} { + pack1 -side right -pady 20 -fill y +} {20x160+280+20 280x200+0+0} +test pack-3.5 {y padding and filling} { + pack1 -side right -ipady 20 -fill y +} {20x200+280+0 280x200+0+0} +test pack-3.6 {y padding and filling} { + pack1 -side right -ipady 5 -pady 10 -fill y +} {20x180+280+10 280x200+0+0} +test pack-3.7 {y padding and filling} { + pack1 -side top -pady 20 +} {20x40+140+20 300x120+0+80} +test pack-3.8 {y padding and filling} { + pack1 -side top -ipady 20 +} {20x80+140+0 300x120+0+80} +test pack-3.9 {y padding and filling} { + pack1 -side top -ipady 5 -pady 10 +} {20x50+140+10 300x130+0+70} +test pack-3.10 {y padding and filling} { + pack1 -side top -pady 20 -fill y +} {20x40+140+20 300x120+0+80} +test pack-3.11 {y padding and filling} { + pack1 -side top -ipady 20 -fill y +} {20x80+140+0 300x120+0+80} +test pack-3.12 {y padding and filling} { + pack1 -side top -ipady 5 -pady 10 -fill y +} {20x50+140+10 300x130+0+70} +set pad [winfo pixels .pack 1c] +test pack-3.13 {y padding and filling} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -pady 1c + set x [pack info .pack.a] + lindex $x [expr [lsearch -exact $x -pady]+1] +} $pad +test pack-3.14 {y padding and filling} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -ipady 1c + set x [pack info .pack.a] + lindex $x [expr [lsearch -exact $x -ipady]+1] +} $pad + +test pack-4.1 {anchors} { + pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n +} {30x70+135+20} +test pack-4.2 {anchors} { + pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne +} {30x70+260+20} +test pack-4.3 {anchors} { + pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e +} {30x70+260+65} +test pack-4.4 {anchors} { + pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se +} {30x70+260+110} +test pack-4.5 {anchors} { + pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s +} {30x70+135+110} +test pack-4.6 {anchors} { + pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw +} {30x70+10+110} +test pack-4.7 {anchors} { + pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w +} {30x70+10+65} +test pack-4.8 {anchors} { + pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw +} {30x70+10+20} +test pack-4.9 {anchors} { + pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center +} {30x70+135+65} + +# Repeat above tests, but with a frame that isn't at (0,0), so that +# we can be sure that the frame offset is being added in correctly. + +test pack-5.1 {more anchors} { + pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n +} {60x60+160+60} +test pack-5.2 {more anchors} { + pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne +} {60x60+230+60} +test pack-5.3 {more anchors} { + pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e +} {60x60+230+90} +test pack-5.4 {more anchors} { + pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se +} {60x60+230+120} +test pack-5.5 {more anchors} { + pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s +} {60x60+160+120} +test pack-5.6 {more anchors} { + pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw +} {60x60+90+120} +test pack-5.7 {more anchors} { + pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w +} {60x60+90+90} +test pack-5.8 {more anchors} { + pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw +} {60x60+90+60} +test pack-5.9 {more anchors} { + pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center +} {60x60+160+90} + +test pack-6.1 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side left + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {20x40+0+80 50x30+20+85 80x80+70+60 40x30+150+85} +test pack-6.2 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side left -expand yes + pack .pack.b -side left + pack .pack.c .pack.d -side left -expand 1 + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {20x40+18+80 50x30+56+85 80x80+124+60 40x30+241+85} +test pack-6.3 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side top + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {20x40+140+0 50x30+125+40 80x80+110+70 40x30+130+150} +test pack-6.4 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side top -expand yes + pack .pack.b -side top + pack .pack.c .pack.d -side top -expand 1 + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {20x40+140+3 50x30+125+46 80x80+110+79 40x30+130+166} +test pack-6.5 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side right + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {20x40+280+80 50x30+230+85 80x80+150+60 40x30+110+85} +test pack-6.6 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side right -expand yes + pack .pack.b -side right + pack .pack.c .pack.d -side right -expand 1 + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {20x40+262+80 50x30+194+85 80x80+95+60 40x30+18+85} +test pack-6.7 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side bottom + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {20x40+140+160 50x30+125+130 80x80+110+50 40x30+130+20} +test pack-6.8 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side bottom -expand yes + pack .pack.b -side bottom + pack .pack.c .pack.d -side bottom -expand 1 + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {20x40+140+157 50x30+125+124 80x80+110+40 40x30+130+3} +test pack-6.9 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side bottom -expand yes -fill both + pack .pack.b -side right + pack .pack.c -side top -expand 1 -fill both + pack .pack.d -side left + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {300x65+0+135 50x30+250+52 250x105+0+0 40x30+0+105} +test pack-6.10 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side left -expand yes -fill both + pack .pack.b -side top + pack .pack.c -side right -expand 1 -fill both + pack .pack.d -side bottom + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {100x200+0+0 50x30+175+0 160x170+140+30 40x30+100+170} +test pack-6.11 {-expand option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side left -expand yes -fill both + pack .pack.b -side top -expand yes -fill both + pack .pack.c -side right -expand 1 -fill both + pack .pack.d -side bottom -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] \ + [winfo geometry .pack.c] [winfo geometry .pack.d] +} {100x200+0+0 200x100+100+0 160x100+140+100 40x100+100+100} +catch {destroy .pack2} +toplevel .pack2 -height 400 -width 400 +wm geometry .pack2 +0+0 +pack propagate .pack2 0 +pack forget .pack2.a .pack2.b .pack2.c .pack2.d +foreach i {w1 w2 w3} { + frame .pack2.$i -width 30 -height 30 -bd 2 -relief raised + label .pack2.$i.l -text $i + place .pack2.$i.l -relwidth 1.0 -relheight 1.0 +} +test pack-6.12 {-expand option} { + pack .pack2.w1 .pack2.w2 .pack2.w3 -padx 5 -ipadx 4 -pady 2 -ipady 6 -expand 1 -side left + update + list [winfo geometry .pack2.w1] [winfo geometry .pack2.w2] [winfo geometry .pack2.w3] +} {38x42+47+179 38x42+180+179 38x42+314+179} +test pack-6.13 {-expand option} { + pack forget .pack2.w1 .pack2.w2 .pack2.w3 + pack .pack2.w1 .pack2.w2 .pack2.w3 -padx 5 -ipadx 4 -pady 2 \ + -ipady 6 -expand 1 -side top + update + list [winfo geometry .pack2.w1] [winfo geometry .pack2.w2] [winfo geometry .pack2.w3] +} {38x42+181+45 38x42+181+178 38x42+181+312} +catch {destroy .pack2} + +wm geometry .pack {} +test pack-7.1 {requesting size for parent} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side left -padx 5 -pady 10 + update + list [winfo reqwidth .pack] [winfo reqheight .pack] +} {230 100} +test pack-7.2 {requesting size for parent} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side top -padx 5 -pady 10 + update + list [winfo reqwidth .pack] [winfo reqheight .pack] +} {90 260} +test pack-7.3 {requesting size for parent} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side right -padx 5 -pady 10 + update + list [winfo reqwidth .pack] [winfo reqheight .pack] +} {230 100} +test pack-7.4 {requesting size for parent} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side bottom -padx 5 -pady 10 + update + list [winfo reqwidth .pack] [winfo reqheight .pack] +} {90 260} +test pack-7.5 {requesting size for parent} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side top -padx 5 -pady 10 + pack .pack.b -side right -padx 5 -pady 10 + pack .pack.c -side bottom -padx 5 -pady 10 + pack .pack.d -side left -padx 5 -pady 10 + update + list [winfo reqwidth .pack] [winfo reqheight .pack] +} {150 210} +test pack-7.6 {requesting size for parent} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side top + pack .pack.c -side left + pack .pack.d -side bottom + update + list [winfo reqwidth .pack] [winfo reqheight .pack] +} {120 120} +test pack-7.7 {requesting size for parent} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side right + pack .pack.c -side bottom + pack .pack.d -side top + update + list [winfo reqwidth .pack] [winfo reqheight .pack] +} {100 110} + + +# For the tests below, create a couple of "pad" windows to shrink +# the available space for the remaining windows. The tests have to +# be done this way rather than shrinking the whole window, because +# some window managers like mwm won't let a top-level window get +# very small. + +pack forget .pack.a .pack.b .pack.c .pack.d +frame .pack.right -width 200 -height 10 -bd 2 -relief raised +frame .pack.bottom -width 10 -height 150 -bd 2 -relief raised +pack .pack.right -side right +pack .pack.bottom -side bottom +pack .pack.a .pack.b .pack.c -side top +update +test pack-8.1 {insufficient space} { + list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} {20x40+30+0 1 50x30+15+40 1 80x80+0+70 1} +wm geom .pack 270x250 +update +test pack-8.2 {insufficient space} { + list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} {20x40+25+0 1 50x30+10+40 1 70x30+0+70 1} +wm geom .pack 240x220 +update +test pack-8.3 {insufficient space} { + list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} {20x40+10+0 1 40x30+0+40 1 70x30+0+70 0} +wm geom .pack 350x350 +update +test pack-8.4 {insufficient space} { + list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} {20x40+65+0 1 50x30+50+40 1 80x80+35+70 1} +wm geom .pack {} +pack .pack.a -side left +pack .pack.b -side right +pack .pack.c -side left +update +test pack-8.5 {insufficient space} { + list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} +wm geom .pack 320x180 +update +test pack-8.6 {insufficient space} { + list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} {20x30+0+0 1 50x30+70+0 1 50x30+20+0 1} +wm geom .pack 250x180 +update +test pack-8.7 {insufficient space} { + list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} {20x30+0+0 1 30x30+20+0 1 50x30+20+0 0} +pack forget .pack.b +update +test pack-8.8 {insufficient space} { + list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} {20x30+0+0 1 30x30+20+0 0 30x30+20+0 1} +pack .pack.b -side right -after .pack.a +wm geom .pack {} +update +test pack-8.9 {insufficient space} { + list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} +pack forget .pack.right .pack.bottom + +test pack-9.1 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side top + pack .pack.a -after .pack.b + pack slaves .pack +} {.pack.b .pack.a .pack.c .pack.d} +test pack-9.2 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side top + pack .pack.a -after .pack.a + pack slaves .pack +} {.pack.a .pack.b .pack.c .pack.d} +test pack-9.3 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side top + pack .pack.a -before .pack.d + pack slaves .pack +} {.pack.b .pack.c .pack.a .pack.d} +test pack-9.4 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side top + pack .pack.d -before .pack.a + pack slaves .pack +} {.pack.d .pack.a .pack.b .pack.c} +test pack-9.5 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side top + pack propagate .pack.c 0 + pack .pack.a -in .pack.c + list [pack slaves .pack] [pack slaves .pack.c] +} {{.pack.b .pack.c .pack.d} .pack.a} +test pack-9.6 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side top + pack .pack.a -in .pack + pack slaves .pack +} {.pack.b .pack.c .pack.d .pack.a} +test pack-9.7 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d -side top + pack .pack.a -padx 0 + pack slaves .pack +} {.pack.a .pack.b .pack.c .pack.d} +test pack-9.8 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c + pack .pack.d + pack slaves .pack +} {.pack.a .pack.b .pack.c .pack.d} +test pack-9.9 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d + pack .pack.b .pack.d .pack.c -before .pack.a + pack slaves .pack +} {.pack.b .pack.d .pack.c .pack.a} +test pack-9.10 {window ordering} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.c .pack.d .pack.b -after .pack.a + pack slaves .pack +} {.pack.a .pack.c .pack.d .pack.b} + +test pack-10.1 {retaining/clearing configuration state} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side bottom -anchor n -padx 1 -pady 2 -ipadx 3 -ipady 4 \ + -fill both -expand 1 + pack forget .pack.a + pack .pack.a + pack info .pack.a +} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} +test pack-10.2 {retaining/clearing configuration state} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side bottom -anchor n -padx 1 -pady 2 -ipadx 3 -ipady 4 \ + -fill both -expand 1 + 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-11.1 {info option} { + pack4 -in .pack +} .pack +test pack-11.2 {info option} { + pack4 -anchor n +} n +test pack-11.3 {info option} { + pack4 -anchor sw +} sw +test pack-11.4 {info option} { + pack4 -expand yes +} 1 +test pack-11.5 {info option} { + pack4 -expand no +} 0 +test pack-11.6 {info option} { + pack4 -fill x +} x +test pack-11.7 {info option} { + pack4 -fill y +} y +test pack-11.8 {info option} { + pack4 -fill both +} both +test pack-11.9 {info option} { + pack4 -fill none +} none +test pack-11.10 {info option} { + pack4 -ipadx 14 +} 14 +test pack-11.11 {info option} { + pack4 -ipady 22 +} 22 +test pack-11.12 {info option} { + pack4 -padx 2 +} 2 +test pack-11.13 {info option} { + pack4 -pady 3 +} 3 +test pack-11.14 {info option} { + pack4 -side top +} top +test pack-11.15 {info option} { + pack4 -side bottom +} bottom +test pack-11.16 {info option} { + pack4 -side left +} left +test pack-11.17 {info option} { + pack4 -side right +} right + +test pack-12.1 {command options and errors} { + list [catch {pack} msg] $msg +} {1 {wrong # args: should be "pack option arg ?arg ...?"}} +test pack-12.2 {command options and errors} { + list [catch {pack foo} msg] $msg +} {1 {wrong # args: should be "pack option arg ?arg ...?"}} +test pack-12.3 {command options and errors} { + list [catch {pack configure x} msg] $msg +} {1 {bad argument "x": must be name of window}} +test pack-12.4 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack configure .pack.b .pack.c + pack slaves .pack +} {.pack.b .pack.c} +test pack-12.5 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .foo} msg] $msg +} {1 {bad window path name ".foo"}} +test pack-12.6 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack} msg] $msg +} {1 {can't pack ".pack": it's a top-level window}} +test pack-12.7 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -after .foo} msg] $msg +} {1 {bad window path name ".foo"}} +test pack-12.8 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -after .pack.b} msg] $msg +} {1 {window ".pack.b" isn't packed}} +test pack-12.9 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -anchor gorp} msg] $msg +} {1 {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}} +test pack-12.10 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -before gorp} msg] $msg +} {1 {bad window path name "gorp"}} +test pack-12.11 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -before .pack.b} msg] $msg +} {1 {window ".pack.b" isn't packed}} +test pack-12.12 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -expand "who cares?"} msg] $msg +} {1 {expected boolean value but got "who cares?"}} +test pack-12.13 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -fill z} msg] $msg +} {1 {bad fill style "z": must be none, x, y, or both}} +test pack-12.14 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -in z} msg] $msg +} {1 {bad window path name "z"}} +set pad [winfo pixels .pack 1c] +test pack-12.15 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -padx abc} msg] $msg +} {1 {bad pad value "abc": must be positive screen distance}} +test pack-12.16 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -padx -1} msg] $msg +} {1 {bad pad value "-1": must be positive screen distance}} +test pack-12.17 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -pady abc} msg] $msg +} {1 {bad pad value "abc": must be positive screen distance}} +test pack-12.18 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -pady -1} msg] $msg +} {1 {bad pad value "-1": must be positive screen distance}} +test pack-12.19 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -ipadx abc} msg] $msg +} {1 {bad pad value "abc": must be positive screen distance}} +test pack-12.20 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -ipadx -1} msg] $msg +} {1 {bad pad value "-1": must be positive screen distance}} +test pack-12.21 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -ipady abc} msg] $msg +} {1 {bad pad value "abc": must be positive screen distance}} +test pack-12.22 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -ipady -1} msg] $msg +} {1 {bad pad value "-1": must be positive screen distance}} +test pack-12.23 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -side bac} msg] $msg +} {1 {bad side "bac": must be top, bottom, left, or right}} +test pack-12.24 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -lousy bac} msg] $msg +} {1 {unknown or ambiguous option "-lousy": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}} +test pack-12.25 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -padx} msg] $msg +} {1 {extra option "-padx" (option with no value?)}} +test pack-12.26 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a {} 22} msg] $msg +} {1 {unknown or ambiguous option "": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}} +test pack-12.27 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -in .} msg] $msg +} {1 {can't pack .pack.a inside .}} +test pack-12.28 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + frame .pack.a.a + list [catch {pack .pack.a.a -in .pack.b} msg] $msg +} {1 {can't pack .pack.a.a inside .pack.b}} +test pack-12.29 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack .pack.a -in .pack.a} msg] $msg +} {1 {can't pack .pack.a inside itself}} +test pack-12.30 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.b .pack.c .pack.d + pack forget .pack.a .pack.d + pack slaves .pack +} {.pack.b .pack.c} +test pack-12.31 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + .pack configure -width 300 -height 200 + pack propagate .pack 0 + pack .pack.a + update + set result [list [winfo reqwidth .pack] [winfo reqheight .pack]] + pack propagate .pack 1 + update + lappend result [winfo reqwidth .pack] [winfo reqheight .pack] + set result +} {300 200 20 40} +test pack-12.32 {command options and errors} { + set result [pack propagate .pack.d] + pack propagate .pack.d 0 + lappend result [pack propagate .pack.d] + pack propagate .pack.d 1 + lappend result [pack propagate .pack.d] + set result +} {1 0 1} +test pack-12.33 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack propagate .dum} msg] $msg +} {1 {bad window path name ".dum"}} +test pack-12.34 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack propagate .pack foo} msg] $msg +} {1 {expected boolean value but got "foo"}} +test pack-12.35 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack propagate .pack foo bar} msg] $msg +} {1 {wrong # args: should be "pack propagate window ?boolean?"}} +test pack-12.36 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack slaves} msg] $msg +} {1 {wrong # args: should be "pack option arg ?arg ...?"}} +test pack-12.37 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack slaves a b} msg] $msg +} {1 {wrong # args: should be "pack slaves window"}} +test pack-12.38 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack slaves .x} msg] $msg +} {1 {bad window path name ".x"}} +test pack-12.39 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack slaves .pack.a} msg] $msg +} {0 {}} +test pack-12.40 {command options and errors} { + pack forget .pack.a .pack.b .pack.c .pack.d + list [catch {pack lousy .pack} msg] $msg +} {1 {bad option "lousy": must be configure, forget, info, propagate, or slaves}} + +pack .pack.right -side right +pack .pack.bottom -side bottom +test pack-13.1 {window deletion} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a .pack.d .pack.b .pack.c -side top + update + destroy .pack.d + update + set result [list [pack slaves .pack] [winfo geometry .pack.a] \ + [winfo geometry .pack.b] [winfo geometry .pack.c]] +} {{.pack.right .pack.bottom .pack.a .pack.b .pack.c} 20x40+30+0 50x30+15+40 80x80+0+70} + +test pack-14.1 {respond to changes in expansion} { + pack forget .pack.a .pack.b .pack.c .pack.d + wm geom .pack {} + pack .pack.a + update + set result [winfo geom .pack.a] + wm geom .pack 400x300 + update + lappend result [winfo geom .pack.a] + pack .pack.a -expand true -fill both + update + lappend result [winfo geom .pack.a] +} {20x40+0+0 20x40+90+0 200x150+0+0} +wm geom .pack {} + +test pack-15.1 {managing geometry with -in option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side top + frame .pack.f + lower .pack.f + pack .pack.f -side top + frame .pack.f.f2 + lower .pack.f.f2 + pack .pack.f.f2 -side top + pack .pack.b -in .pack.f.f2 + update + set result [winfo geom .pack.b] + pack unpack .pack.a + update + lappend result [winfo geom .pack.b] +} {50x30+0+40 50x30+0+0} +catch {destroy .pack.f} +test pack-15.2 {managing geometry with -in option} { + pack forget .pack.a .pack.b .pack.c .pack.d + frame .pack.f + lower .pack.f + pack .pack.a -in .pack.f -side top + update + set result [winfo ismapped .pack.a] + place .pack.f -x 30 -y 45 + update + lappend result [winfo ismapped .pack.a] [winfo geometry .pack.a] + place forget .pack.f + update + lappend result [winfo ismapped .pack.a] +} {0 1 20x40+30+45 0} +catch {destroy .pack.f} +test pack-15.3 {managing geometry with -in option} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a -side top + frame .pack.f + lower .pack.f + pack .pack.f -side top + frame .pack.f.f2 + lower .pack.f.f2 + pack .pack.f.f2 -side top + pack .pack.b -in .pack.f.f2 + update + set result [winfo ismapped .pack.b] + pack unpack .pack.f + update + lappend result [winfo ismapped .pack.b] +} {1 0} +catch {destroy .pack.f} +test pack-15.4 {managing geometry with -in option} { + pack forget .pack.a .pack.b .pack.c .pack.d + foreach i {1 2} { + frame .pack.f$i -width 100 -height 40 -bd 2 -relief raised + lower .pack.f$i + pack propagate .pack.f$i 0 + pack .pack.f$i -side top + } + pack .pack.b -in .pack.f1 -side right + update + set result {} + lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b] + pack .pack.b -in .pack.f2 -side bottom + update + lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b] + .pack.f1 configure -width 50 -height 20 + update + lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b] + pack forget .pack.b + update + lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b] +} {50x30+48+5 1 50x30+25+48 1 50x30+25+28 1 50x30+25+28 0} +catch {destroy .pack.f1 .pack.f2} +test pack-15.5 {managing geometry with -in option} { + pack forget .pack.a .pack.b .pack.c .pack.d + foreach i {1 2} { + frame .pack.f$i -width 100 -height 20 -bd 2 -relief raised + lower .pack.f$i + pack propagate .pack.f$i 0 + pack .pack.f$i -side top + } + pack .pack.b -in .pack.f2 -side top + update + set result {} + lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b] + pack .pack.a -before .pack.b -side top + update + lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b] +} {50x16+25+22 1 50x16+25+22 0} +catch {destroy .pack.f1 .pack.f2} + +test pack-16.1 {geometry manager name} { + pack forget .pack.a .pack.b .pack.c .pack.d + set result {} + lappend result [winfo manager .pack.a] + pack .pack.a + lappend result [winfo manager .pack.a] + pack forget .pack.a + lappend result [winfo manager .pack.a] +} {{} pack {}} + +test pack-17.1 {PackLostSlaveProc procedure} { + pack forget .pack.a .pack.b .pack.c .pack.d + pack .pack.a + update + place .pack.a -x 40 -y 10 + update + list [winfo manager .pack.a] [winfo geometry .pack.a] \ + [catch {pack info .pack.a} msg] $msg +} {place 20x40+40+10 1 {window ".pack.a" isn't packed}} + +test pack-18.1 {unmap slaves when master unmapped} {tempNotPc} { + # On the PC, when the width/height is configured while the window is + # unmapped, the changes don't take effect until the window is remapped. + # Who knows why? + + eval destroy [winfo child .pack] + frame .pack.a -width 100 -height 50 -relief raised -bd 2 + pack .pack.a + update + set result [winfo ismapped .pack.a] + wm iconify .pack + update + lappend result [winfo ismapped .pack.a] + .pack.a configure -width 200 -height 75 + update + lappend result [winfo width .pack.a ] [winfo height .pack.a] \ + [winfo ismapped .pack.a] + wm deiconify .pack + update + lappend result [winfo ismapped .pack.a] +} {1 0 200 75 0 1} +test pack-18.2 {unmap slaves when master unmapped} { + eval destroy [winfo child .pack] + frame .pack.a -relief raised -bd 2 + frame .pack.b -width 70 -height 30 -relief sunken -bd 2 + pack .pack.a + pack .pack.b -in .pack.a + update + set result [winfo ismapped .pack.b] + wm iconify .pack + update + lappend result [winfo ismapped .pack.b] + .pack.b configure -width 100 -height 30 + update + lappend result [winfo width .pack.b ] [winfo height .pack.b] \ + [winfo ismapped .pack.b] + wm deiconify .pack + update + lappend result [winfo ismapped .pack.b] +} {1 0 100 30 0 1} +destroy .pack +foreach i {pack1 pack2 pack3 pack4} { + rename $i {} +} diff --git a/tests/place.test b/tests/place.test new file mode 100644 index 0000000..06540e3 --- /dev/null +++ b/tests/place.test @@ -0,0 +1,221 @@ +# This file is a Tcl script to test out the "place" command. It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) place.test 1.6 96/02/16 10:56:01 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# XXX - This test file is woefully incomplete. At present, only a +# few of the features are tested. + +toplevel .t -width 300 -height 200 -bd 0 +wm geom .t +0+0 +frame .t.f -width 154 -height 84 -bd 2 -relief raised +place .t.f -x 48 -y 38 +frame .t.f2 -width 30 -height 60 -bd 2 -relief raised +update + +test place-1.1 {Tk_PlaceCmd procedure, "info" option} { + place .t.f2 -x 0 + place info .t.f2 +} {-x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw} +test place-1.2 {Tk_PlaceCmd procedure, "info" option} { + place .t.f2 -x 1 -y 2 -width 3 -height 4 -relx 0.1 -rely 0.2 \ + -relwidth 0.3 -relheight 0.4 -anchor se -in .t.f \ + -bordermode outside + place info .t.f2 +} {-x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside -in .t.f} + +test place-2.1 {ConfigureSlave procedure, -height option} { + list [catch {place .t.f2 -height abcd} msg] $msg +} {1 {bad screen distance "abcd"}} +test place-2.2 {ConfigureSlave procedure, -height option} { + place forget .t.f2 + place .t.f2 -in .t.f -height 40 + update + winfo height .t.f2 +} {40} +test place-2.3 {ConfigureSlave procedure, -height option} { + place forget .t.f2 + place .t.f2 -in .t.f -height 120 + update + place .t.f2 -height {} + update + winfo height .t.f2 +} {60} + +test place-3.1 {ConfigureSlave procedure, -relheight option} { + list [catch {place .t.f2 -relheight abcd} msg] $msg +} {1 {expected floating-point number but got "abcd"}} +test place-3.2 {ConfigureSlave procedure, -relheight option} { + place forget .t.f2 + place .t.f2 -in .t.f -relheight .5 + update + winfo height .t.f2 +} {40} +test place-3.3 {ConfigureSlave procedure, -relheight option} { + place forget .t.f2 + place .t.f2 -in .t.f -relheight .8 + update + place .t.f2 -relheight {} + update + winfo height .t.f2 +} {60} + +test place-4.1 {ConfigureSlave procedure, bad -in options} { + place forget .t.f2 + list [catch {place .t.f2 -in .t.f2} msg] $msg +} {1 {can't place .t.f2 relative to itself}} + +test place-5.1 {ConfigureSlave procedure, -relwidth option} { + list [catch {place .t.f2 -relwidth abcd} msg] $msg +} {1 {expected floating-point number but got "abcd"}} +test place-5.2 {ConfigureSlave procedure, -relwidth option} { + place forget .t.f2 + place .t.f2 -in .t.f -relwidth .5 + update + winfo width .t.f2 +} {75} +test place-5.3 {ConfigureSlave procedure, -relwidth option} { + place forget .t.f2 + place .t.f2 -in .t.f -relwidth .8 + update + place .t.f2 -relwidth {} + update + winfo width .t.f2 +} {30} + +test place-6.1 {ConfigureSlave procedure, -width option} { + list [catch {place .t.f2 -width abcd} msg] $msg +} {1 {bad screen distance "abcd"}} +test place-6.2 {ConfigureSlave procedure, -width option} { + place forget .t.f2 + place .t.f2 -in .t.f -width 100 + update + winfo width .t.f2 +} {100} +test place-6.3 {ConfigureSlave procedure, -width option} { + place forget .t.f2 + place .t.f2 -in .t.f -width 120 + update + place .t.f2 -width {} + update + winfo width .t.f2 +} {30} + +test place-7.1 {ReconfigurePlacement procedure, computing position} { + place forget .t.f2 + place .t.f2 -in .t.f -x -2 -relx .5 -y 3 -rely .4 + update + winfo geometry .t.f2 +} {30x60+123+75} +test place-7.2 {ReconfigurePlacement procedure, position rounding} { + place forget .t.f2 + place .t.f2 -in .t.f -x -1.4 -y -2.3 + update + winfo geometry .t.f2 +} {30x60+49+38} +test place-7.3 {ReconfigurePlacement procedure, position rounding} { + place forget .t.f2 + place .t.f2 -in .t.f -x 1.4 -y 2.3 + update + winfo geometry .t.f2 +} {30x60+51+42} +test place-7.4 {ReconfigurePlacement procedure, position rounding} { + place forget .t.f2 + place .t.f2 -in .t.f -x -1.6 -y -2.7 + update + winfo geometry .t.f2 +} {30x60+48+37} +test place-7.5 {ReconfigurePlacement procedure, position rounding} { + place forget .t.f2 + place .t.f2 -in .t.f -x 1.6 -y 2.7 + update + winfo geometry .t.f2 +} {30x60+52+43} +test place-7.6 {ReconfigurePlacement procedure, position rounding} { + frame .t.f3 -width 100 -height 100 -bg #f00000 -bd 0 + place .t.f3 -x 0 -y 0 + raise .t.f2 + place forget .t.f2 + place .t.f2 -in .t.f3 -relx .303 -rely .406 -relwidth .304 -relheight .206 + update + winfo geometry .t.f2 +} {31x20+30+41} +catch {destroy .t.f3} +test place-7.7 {ReconfigurePlacement procedure, computing size} { + place forget .t.f2 + place .t.f2 -in .t.f -width 120 -height 89 + update + list [winfo width .t.f2] [winfo height .t.f2] +} {120 89} +test place-7.8 {ReconfigurePlacement procedure, computing size} { + place forget .t.f2 + place .t.f2 -in .t.f -relwidth .4 -relheight .5 + update + list [winfo width .t.f2] [winfo height .t.f2] +} {60 40} +test place-7.9 {ReconfigurePlacement procedure, computing size} { + place forget .t.f2 + place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5 + update + list [winfo width .t.f2] [winfo height .t.f2] +} {70 36} +test place-7.10 {ReconfigurePlacement procedure, computing size} { + place forget .t.f2 + place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5 + place .t.f2 -width {} -relwidth {} -height {} -relheight {} + update + list [winfo width .t.f2] [winfo height .t.f2] +} {30 60} + + +test place-8.1 {MasterStructureProc, mapping and unmapping slaves} { + place forget .t.f2 + place forget .t.f + place .t.f2 -relx 1.0 -rely 1.0 -anchor sw + update + set result [winfo ismapped .t.f2] + wm iconify .t + update + lappend result [winfo ismapped .t.f2] + place .t.f2 -x 40 -y 30 -relx 0 -rely 0 -anchor nw + update + lappend result [winfo x .t.f2] [winfo y .t.f2] [winfo ismapped .t.f2] + wm deiconify .t + update + lappend result [winfo ismapped .t.f2] +} {1 0 40 30 0 1} +test place-8.2 {MasterStructureProc, mapping and unmapping slaves} { + place forget .t.f2 + place forget .t.f + place .t.f -x 0 -y 0 -width 200 -height 100 + place .t.f2 -in .t.f -relx 1.0 -rely 1.0 -anchor sw -width 50 -height 20 + update + set result [winfo ismapped .t.f2] + wm iconify .t + update + lappend result [winfo ismapped .t.f2] + place .t.f2 -x 40 -y 30 -relx 0 -rely 0 -anchor nw + update + lappend result [winfo x .t.f2] [winfo y .t.f2] [winfo ismapped .t.f2] + wm deiconify .t + update + lappend result [winfo ismapped .t.f2] +} {1 0 42 32 0 1} + +catch {destroy .t} +concat diff --git a/tests/raise.test b/tests/raise.test new file mode 100644 index 0000000..af13746 --- /dev/null +++ b/tests/raise.test @@ -0,0 +1,299 @@ +# This file is a Tcl script to test out Tk's "raise" and +# "lower" commands, plus associated code to manage window +# stacking order. It is organized in the standard fashion +# for Tcl tests. +# +# Copyright (c) 1993-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) raise.test 1.8 96/02/16 10:55:18 + +if {[info commands testmakeexist] == {}} { + puts "This application hasn't been compiled with the \"testmakeexist\"" + puts "command, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +# Procedure to create a bunch of overlapping windows, which should +# make it easy to detect differences in order. + +proc raise_setup {} { + foreach i [winfo child .raise] { + destroy $i + } + foreach i {a b c d e} { + label .raise.$i -text $i -relief raised -bd 2 + } + place .raise.a -x 20 -y 60 -width 60 -height 80 + place .raise.b -x 60 -y 60 -width 60 -height 80 + place .raise.c -x 100 -y 60 -width 60 -height 80 + place .raise.d -x 40 -y 20 -width 100 -height 60 + place .raise.e -x 40 -y 120 -width 100 -height 60 +} + +# Procedure to return information about which windows are on top +# of which other windows. + +proc raise_getOrder {} { + set x [winfo rootx .raise] + set y [winfo rooty .raise] + list [winfo name [winfo containing [expr $x+50] [expr $y+70]]] \ + [winfo name [winfo containing [expr $x+90] [expr $y+70]]] \ + [winfo name [winfo containing [expr $x+130] [expr $y+70]]] \ + [winfo name [winfo containing [expr $x+70] [expr $y+100]]] \ + [winfo name [winfo containing [expr $x+110] [expr $y+100]]] \ + [winfo name [winfo containing [expr $x+50] [expr $y+130]]] \ + [winfo name [winfo containing [expr $x+90] [expr $y+130]]] \ + [winfo name [winfo containing [expr $x+130] [expr $y+130]]] +} + +# Procedure to set up a collection of top-level windows + +proc raise_makeToplevels {} { + foreach i [winfo child .] { + destroy $i + } + foreach i {.raise1 .raise2 .raise3} { + toplevel $i + wm geom $i 150x100+0+0 + update + } +} + +foreach i [winfo child .] { + destroy $i +} +toplevel .raise +wm geom .raise 250x200+0+0 + +test raise-1.1 {preserve creation order} { + raise_setup + update + raise_getOrder +} {d d d b c e e e} +test raise-1.2 {preserve creation order} { + raise_setup + testmakeexist .raise.a + update + raise_getOrder +} {d d d b c e e e} +test raise-1.3 {preserve creation order} { + raise_setup + testmakeexist .raise.c + update + raise_getOrder +} {d d d b c e e e} +test raise-1.4 {preserve creation order} { + raise_setup + testmakeexist .raise.e + update + raise_getOrder +} {d d d b c e e e} +test raise-1.5 {preserve creation order} { + raise_setup + testmakeexist .raise.d .raise.c .raise.b + update + raise_getOrder +} {d d d b c e e e} + +test raise-2.1 {raise internal windows before creation} { + raise_setup + raise .raise.a + update + raise_getOrder +} {a d d a c a e e} +test raise-2.2 {raise internal windows before creation} { + raise_setup + raise .raise.c + update + raise_getOrder +} {d d c b c e e c} +test raise-2.3 {raise internal windows before creation} { + raise_setup + raise .raise.e + update + raise_getOrder +} {d d d b c e e e} +test raise-2.4 {raise internal windows before creation} { + raise_setup + raise .raise.e .raise.a + update + raise_getOrder +} {d d d b c e b c} +test raise-2.5 {raise internal windows before creation} { + raise_setup + raise .raise.a .raise.d + update + raise_getOrder +} {a d d a c e e e} + +test raise-3.1 {raise internal windows after creation} { + raise_setup + update + raise .raise.a .raise.d + raise_getOrder +} {a d d a c e e e} +test raise-3.2 {raise internal windows after creation} { + raise_setup + testmakeexist .raise.a .raise.b + raise .raise.a .raise.b + update + raise_getOrder +} {d d d a c e e e} +test raise-3.3 {raise internal windows after creation} { + raise_setup + testmakeexist .raise.a .raise.d + raise .raise.a .raise.b + update + raise_getOrder +} {d d d a c e e e} +test raise-3.4 {raise internal windows after creation} { + raise_setup + testmakeexist .raise.a .raise.c .raise.d + raise .raise.a .raise.b + update + raise_getOrder +} {d d d a c e e e} + +test raise-4.1 {raise relative to nephews} { + raise_setup + update + frame .raise.d.child + raise .raise.a .raise.d.child + raise_getOrder +} {a d d a c e e e} +test raise-4.2 {raise relative to nephews} { + raise_setup + update + frame .raise2 + list [catch {raise .raise.a .raise2} msg] $msg +} {1 {can't raise ".raise.a" above ".raise2"}} +catch {destroy .raise2} + +test raise-5.1 {lower internal windows} { + raise_setup + update + lower .raise.d + raise_getOrder +} {a b c b c e e e} +test raise-5.2 {lower internal windows} { + raise_setup + update + lower .raise.d .raise.b + raise_getOrder +} {d b c b c e e e} +test raise-5.3 {lower internal windows} { + raise_setup + update + lower .raise.a .raise.e + raise_getOrder +} {a d d a c e e e} +test raise-5.4 {lower internal windows} { + raise_setup + update + frame .raise2 + list [catch {lower .raise.a .raise2} msg] $msg +} {1 {can't lower ".raise.a" below ".raise2"}} +catch {destroy .raise2} + +test raise-6.1 {raise/lower toplevel windows} {nonPortable} { + raise_makeToplevels + update + raise .raise1 + winfo containing [winfo rootx .raise1] [winfo rooty .raise1] +} .raise1 +test raise-6.2 {raise/lower toplevel windows} {nonPortable} { + raise_makeToplevels + update + raise .raise2 + winfo containing [winfo rootx .raise1] [winfo rooty .raise1] +} .raise2 +test raise-6.3 {raise/lower toplevel windows} {nonPortable} { + raise_makeToplevels + update + raise .raise3 + raise .raise2 + raise .raise1 .raise3 + set result [winfo containing [winfo rootx .raise1] \ + [winfo rooty .raise1]] + destroy .raise2 + update + after 500 + list $result [winfo containing [winfo rootx .raise1] \ + [winfo rooty .raise1]] +} {.raise2 .raise1} +test raise-6.4 {raise/lower toplevel windows} {nonPortable} { + raise_makeToplevels + update + raise .raise2 + raise .raise1 + lower .raise3 .raise1 + set result [winfo containing [winfo rootx .raise1] \ + [winfo rooty .raise1]] + wm geometry .raise2 +30+30 + wm geometry .raise1 +60+60 + destroy .raise1 + update + after 500 + list $result [winfo containing [winfo rootx .raise2] \ + [winfo rooty .raise2]] +} {.raise1 .raise3} +test raise-6.5 {raise/lower toplevel windows} {nonPortable} { + raise_makeToplevels + raise .raise1 + set time [lindex [time {raise .raise1}] 0] + expr {$time < 2000000} +} 1 +test raise-6.6 {raise/lower toplevel windows} {nonPortable} { + raise_makeToplevels + update + raise .raise2 + raise .raise1 + raise .raise3 + frame .raise1.f1 + frame .raise1.f1.f2 + lower .raise3 .raise1.f1.f2 + set result [winfo containing [winfo rootx .raise1] \ + [winfo rooty .raise1]] + destroy .raise1 + update + after 500 + list $result [winfo containing [winfo rootx .raise2] \ + [winfo rooty .raise2]] +} {.raise1 .raise3} + +test raise-7.1 {errors in raise/lower commands} { + list [catch {raise} msg] $msg +} {1 {wrong # args: should be "raise window ?aboveThis?"}} +test raise-7.2 {errors in raise/lower commands} { + list [catch {raise a b c} msg] $msg +} {1 {wrong # args: should be "raise window ?aboveThis?"}} +test raise-7.3 {errors in raise/lower commands} { + list [catch {raise badName} msg] $msg +} {1 {bad window path name "badName"}} +test raise-7.4 {errors in raise/lower commands} { + list [catch {raise . badName2} msg] $msg +} {1 {bad window path name "badName2"}} +test raise-7.5 {errors in raise/lower commands} { + list [catch {lower} msg] $msg +} {1 {wrong # args: should be "lower window ?belowThis?"}} +test raise-7.6 {errors in raise/lower commands} { + list [catch {lower a b c} msg] $msg +} {1 {wrong # args: should be "lower window ?belowThis?"}} +test raise-7.7 {errors in raise/lower commands} { + list [catch {lower badName3} msg] $msg +} {1 {bad window path name "badName3"}} +test raise-7.8 {errors in raise/lower commands} { + list [catch {lower . badName4} msg] $msg +} {1 {bad window path name "badName4"}} + +foreach i [winfo child .] { + destroy $i +} diff --git a/tests/safe.test b/tests/safe.test new file mode 100644 index 0000000..65aed36 --- /dev/null +++ b/tests/safe.test @@ -0,0 +1,122 @@ +# This file is a Tcl script to test the Safe Tk facility. It is organized +# in the standard fashion for Tk tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) safe.test 1.15 97/08/13 16:05:17 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} + +# The set of hidden commands is platform dependent: + +if {"$tcl_platform(platform)" == "macintosh"} { + set hidden_cmds {beep bell cd clipboard echo exit fconfigure file glob grab load ls menu open pwd selection socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} +} elseif {"$tcl_platform(platform)" == "windows"} { + set hidden_cmds {bell cd clipboard exec exit fconfigure file glob grab load menu open pwd selection socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} +} else { + set hidden_cmds {bell cd clipboard exec exit fconfigure file glob grab load menu open pwd selection send socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} +} + +test safe-1.1 {Safe Tk loading into an interpreter} { + catch {safe::interpDelete a} + safe::loadTk [safe::interpCreate a] + safe::interpDelete a + set x {} + set x +} "" +test safe-1.2 {Safe Tk loading into an interpreter} { + catch {safe::interpDelete a} + safe::interpCreate a + safe::loadTk a + set l [lsort [interp hidden a]] + safe::interpDelete a + set l +} $hidden_cmds +test safe-1.3 {Safe Tk loading into an interpreter} { + catch {safe::interpDelete a} + safe::interpCreate a + safe::loadTk a + set l [lsort [interp aliases a]] + safe::interpDelete a + set l +} {exit file load source} + +test safe-2.1 {Unsafe commands not available} { + catch {safe::interpDelete a} + safe::interpCreate a + safe::loadTk a + set status broken + if {[catch {interp eval a {toplevel .t}} msg]} { + set status ok + } + safe::interpDelete a + set status +} ok +test safe-2.2 {Unsafe commands not available} { + catch {safe::interpDelete a} + safe::interpCreate a + safe::loadTk a + set status broken + if {[catch {interp eval a {menu .m}} msg]} { + set status ok + } + safe::interpDelete a + set status +} ok + +test safe-3.1 {Unsafe commands are available hidden} { + catch {safe::interpDelete a} + safe::interpCreate a + safe::loadTk a + set status ok + if {[catch {interp invokehidden a toplevel .t} msg]} { + set status broken + } + safe::interpDelete a + set status +} ok +test safe-3.2 {Unsafe commands are available hidden} { + catch {safe::interpDelete a} + safe::interpCreate a + safe::loadTk a + set status ok + if {[catch {interp invokehidden a menu .m} msg]} { + set status broken + } + safe::interpDelete a + set status +} ok + +test safe-4.1 {testing loadTk} { + # no error shall occur, the user will + # eventually see a new toplevel + set i [safe::loadTk [safe::interpCreate]] + interp eval $i {button .b -text "hello world!"; pack .b} +# lets don't update because it might impy that the user has +# to position the window (if the wm does not do it automatically) +# and thus make the test suite not runable non interactively + safe::interpDelete $i +} {} + +test safe-4.2 {testing loadTk -use} { + set w .safeTkFrame + catch {destroy $w} + frame $w -container 1; + pack .safeTkFrame + set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]] + interp eval $i {button .b -text "hello world!"; pack .b} + safe::interpDelete $i + destroy $w +} {} + +unset hidden_cmds diff --git a/tests/scale.test b/tests/scale.test new file mode 100644 index 0000000..405a529 --- /dev/null +++ b/tests/scale.test @@ -0,0 +1,801 @@ +# This file is a Tcl script to test out the "scale" command +# of Tk. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) scale.test 1.28 97/07/31 10:20:43 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Scale.borderWidth 2 +option add *Scale.highlightThickness 2 +option add *Scale.font {Helvetica -12 bold} + +scale .s -from 100 -to 300 +pack .s +update +set i 1 +foreach test { + {-activebackground #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-background #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-bd 4 4 badValue {bad screen distance "badValue"}} + {-bigincrement 12.5 12.5 badValue + {expected floating-point number but got "badValue"}} + {-bg #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-command "set x" {set x} {} {}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-digits 5 5 badValue {expected integer but got "badValue"}} + {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}} + {-font fixed fixed {} {font "" doesn't exist}} + {-foreground green green badValue {unknown color name "badValue"}} + {-from -15.0 -15.0 badValue + {expected floating-point number but got "badValue"}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} + {-highlightcolor #123456 #123456 non-existent + {unknown color name "non-existent"}} + {-highlightthickness 2 2 badValue {bad screen distance "badValue"}} + {-label "Some text" {Some text} {} {}} + {-length 130 130 badValue {bad screen distance "badValue"}} + {-orient horizontal horizontal badValue + {bad orientation "badValue": must be vertical or horizontal}} + {-orient horizontal horizontal {} {}} + {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-repeatdelay 14 14 bogus {expected integer but got "bogus"}} + {-repeatinterval 14 14 bogus {expected integer but got "bogus"}} + {-resolution 2.0 2.0 badValue + {expected floating-point number but got "badValue"}} + {-showvalue 0 0 badValue {expected boolean value but got "badValue"}} + {-sliderlength 86 86 badValue {bad screen distance "badValue"}} + {-sliderrelief raised raised badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-state disabled disabled badValue + {bad state value "badValue": must be normal, active, or disabled}} + {-state normal normal {} {}} + {-takefocus "any string" "any string" {} {}} + {-tickinterval 4.3 4.0 badValue + {expected floating-point number but got "badValue"}} + {-to 14.9 15.0 badValue + {expected floating-point number but got "badValue"}} + {-troughcolor #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-variable x x {} {}} + {-width 32 32 badValue {bad screen distance "badValue"}} +} { + set name [lindex $test 0] + test scale-1.$i {configuration options} { + .s configure $name [lindex $test 1] + lindex [.s configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test scale-1.$i {configuration options} { + list [catch {.s configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .s configure $name [lindex [.s configure $name] 3] + incr i +} + +destroy .s +test scale-2.1 {Tk_ScaleCmd procedure} { + list [catch {scale} msg] $msg +} {1 {wrong # args: should be "scale pathName ?options?"}} +test scale-2.2 {Tk_ScaleCmd procedure} { + list [catch {scale foo} msg] $msg [winfo child .] +} {1 {bad window path name "foo"} {}} +test scale-2.3 {Tk_ScaleCmd procedure} { + list [catch {scale .s -gorp dumb} msg] $msg [winfo child .] +} {1 {unknown option "-gorp"} {}} + +scale .s -from 100 -to 200 +pack .s +update idletasks +test scale-3.1 {ScaleWidgetCmd procedure} { + list [catch {.s} msg] $msg +} {1 {wrong # args: should be ".s option ?arg arg ...?"}} +test scale-3.2 {ScaleWidgetCmd procedure, cget option} { + list [catch {.s cget} msg] $msg +} {1 {wrong # args: should be ".s cget option"}} +test scale-3.3 {ScaleWidgetCmd procedure, cget option} { + list [catch {.s cget a b} msg] $msg +} {1 {wrong # args: should be ".s cget option"}} +test scale-3.4 {ScaleWidgetCmd procedure, cget option} { + list [catch {.s cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test scale-3.5 {ScaleWidgetCmd procedure, cget option} { + .s cget -highlightthickness +} {2} +test scale-3.6 {ScaleWidgetCmd procedure, configure option} { + list [llength [.s configure]] [lindex [.s configure] 5] +} {33 {-borderwidth borderWidth BorderWidth 2 2}} +test scale-3.7 {ScaleWidgetCmd procedure, configure option} { + list [catch {.s configure -foo} msg] $msg +} {1 {unknown option "-foo"}} +test scale-3.8 {ScaleWidgetCmd procedure, configure option} { + list [catch {.s configure -borderwidth 2 -bg} msg] $msg +} {1 {value for "-bg" missing}} +test scale-3.9 {ScaleWidgetCmd procedure, coords option} { + list [catch {.s coords a b} msg] $msg +} {1 {wrong # args: should be ".s coords ?value?"}} +test scale-3.10 {ScaleWidgetCmd procedure, coords option} { + list [catch {.s coords bad} msg] $msg +} {1 {expected floating-point number but got "bad"}} +test scale-3.11 {ScaleWidgetCmd procedure} {fonts} { + .s set 120 + .s coords +} {38 34} +test scale-3.12 {ScaleWidgetCmd procedure, coords option} {fonts} { + .s configure -orient horizontal + update + .s set 120 + .s coords +} {34 31} +.s configure -orient vertical +update +test scale-3.13 {ScaleWidgetCmd procedure, get option} { + list [catch {.s get a} msg] $msg +} {1 {wrong # args: should be ".s get ?x y?"}} +test scale-3.14 {ScaleWidgetCmd procedure, get option} { + list [catch {.s get a b c} msg] $msg +} {1 {wrong # args: should be ".s get ?x y?"}} +test scale-3.15 {ScaleWidgetCmd procedure, get option} { + list [catch {.s get a 11} msg] $msg +} {1 {expected integer but got "a"}} +test scale-3.16 {ScaleWidgetCmd procedure, get option} { + list [catch {.s get 12 b} msg] $msg +} {1 {expected integer but got "b"}} +test scale-3.17 {ScaleWidgetCmd procedure, get option} { + .s set 133 + .s get +} 133 +test scale-3.18 {ScaleWidgetCmd procedure, get option} { + .s configure -resolution 0.5 + .s set 150 + .s get 37 34 +} 119.5 +.s configure -resolution 1 +test scale-3.19 {ScaleWidgetCmd procedure, identify option} { + list [catch {.s identify} msg] $msg +} {1 {wrong # args: should be ".s identify x y"}} +test scale-3.20 {ScaleWidgetCmd procedure, identify option} { + list [catch {.s identify 1 2 3} msg] $msg +} {1 {wrong # args: should be ".s identify x y"}} +test scale-3.21 {ScaleWidgetCmd procedure, identify option} { + list [catch {.s identify boo 16} msg] $msg +} {1 {expected integer but got "boo"}} +test scale-3.22 {ScaleWidgetCmd procedure, identify option} { + list [catch {.s identify 17 bad} msg] $msg +} {1 {expected integer but got "bad"}} +test scale-3.23 {ScaleWidgetCmd procedure, identify option} {fonts} { + .s set 120 + list [.s identify 35 10] [.s identify 35 30] [.s identify 35 80] [.s identify 5 80] +} {trough1 slider trough2 {}} +test scale-3.24 {ScaleWidgetCmd procedure, set option} { + list [catch {.s set} msg] $msg +} {1 {wrong # args: should be ".s set value"}} +test scale-3.25 {ScaleWidgetCmd procedure, set option} { + list [catch {.s set a b} msg] $msg +} {1 {wrong # args: should be ".s set value"}} +test scale-3.26 {ScaleWidgetCmd procedure, set option} { + list [catch {.s set bad} msg] $msg +} {1 {expected floating-point number but got "bad"}} +test scale-3.27 {ScaleWidgetCmd procedure, set option} { + .s set 142 +} {} +test scale-3.28 {ScaleWidgetCmd procedure, set option} { + .s set 118 + .s configure -state disabled + .s set 181 + .s configure -state normal + .s get +} {118} +test scale-3.29 {ScaleWidgetCmd procedure} { + list [catch {.s dumb} msg] $msg +} {1 {bad option "dumb": must be cget, configure, coords, get, identify, or set}} +test scale-3.30 {ScaleWidgetCmd procedure} { + list [catch {.s c} msg] $msg +} {1 {bad option "c": must be cget, configure, coords, get, identify, or set}} +test scale-3.31 {ScaleWidgetCmd procedure} { + list [catch {.s co} msg] $msg +} {1 {bad option "co": must be cget, configure, coords, get, identify, or set}} +test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} { + proc kill args { + destroy .s + } + catch {destroy .s} + scale .s -variable x -from 0 -to 100 -orient horizontal + pack .s + update + .s configure -command kill + .s set 55 +} {} + +test scale-4.1 {DestroyScale procedure} { + catch {destroy .s} + set x 50 + scale .s -variable x -from 0 -to 100 -orient horizontal + pack .s + update + destroy .s + list [catch {set x foo} msg] $msg $x +} {0 foo foo} + +test scale-5.1 {ConfigureScale procedure} { + catch {destroy .s} + set x 66 + set y 77 + scale .s -variable x -from 0 -to 100 + pack .s + update + .s configure -variable y + list [catch {set x foo} msg] $msg $x [.s get] +} {0 foo foo 77} +test scale-5.2 {ConfigureScale procedure} { + catch {destroy .s} + scale .s -from 0 -to 100 + list [catch {.s configure -foo bar} msg] $msg +} {1 {unknown option "-foo"}} +test scale-5.3 {ConfigureScale procedure} { + catch {destroy .s} + catch {unset x} + scale .s -from 0 -to 100 -variable x + set result $x + lappend result [.s get] + set x 92 + lappend result [.s get] + .s set 3 + lappend result $x + unset x + lappend result [catch {set x} msg] $msg +} {0 0 92 3 0 3} +test scale-5.4 {ConfigureScale procedure} { + catch {destroy .s} + scale .s -from 0 -to 100 + list [catch {.s configure -orient dumb} msg] $msg +} {1 {bad orientation "dumb": must be vertical or horizontal}} +test scale-5.5 {ConfigureScale procedure} { + catch {destroy .s} + scale .s -from 1.11 -to 1.89 -resolution .1 -tickinterval .76 + list [format %.1f [.s cget -from]] [format %.1f [.s cget -to]] \ + [format %.1f [.s cget -tickinterval]] +} {1.1 1.9 0.8} +test scale-5.6 {ConfigureScale procedure} { + catch {destroy .s} + scale .s -from 1 -to 10 -tickinterval -2 + pack .s + set result [lindex [.s configure -tickinterval] 4] + .s configure -from 10 -to 1 -tickinterval 2 + lappend result [lindex [.s configure -tickinterval] 4] +} {2.0 -2.0} +test scale-5.7 {ConfigureScale procedure} { + catch {destroy .s} + list [catch {scale .s -from 0 -to 100 -state bogus} msg] $msg +} {1 {bad state value "bogus": must be normal, active, or disabled}} + +catch {destroy .s} +scale .s -orient horizontal -length 200 +pack .s +test scale-6.1 {ComputeFormat procedure} { + .s configure -from 10 -to 100 -resolution 10 + .s set 49.3 + .s get +} {50} +test scale-6.2 {ComputeFormat procedure} { + .s configure -from 100 -to 1000 -resolution 100 + .s set 493 + .s get +} {500} +test scale-6.3 {ComputeFormat procedure} { + .s configure -from 1000 -to 10000 -resolution 1000 + .s set 4930 + .s get +} {5000} +test scale-6.4 {ComputeFormat procedure} { + .s configure -from 10000 -to 100000 -resolution 10000 + .s set 49000 + .s get +} {50000} +test scale-6.5 {ComputeFormat procedure} { + .s configure -from 100000 -to 1000000 -resolution 100000 + .s set 493000 + .s get +} {500000} +test scale-6.6 {ComputeFormat procedure} {nonPortable} { + # This test is non-portable because some platforms format the + # result as 5e+06. + + .s configure -from 1000000 -to 10000000 -resolution 1000000 + .s set 4930000 + .s get +} {5000000} +test scale-6.7 {ComputeFormat procedure} { + .s configure -from 1000000000 -to 10000000000 -resolution 1000000000 + .s set 4930000000 + .s get +} {5.0e+09} +test scale-6.8 {ComputeFormat procedure} { + .s configure -from .1 -to 1 -resolution .1 + .s set .6 + .s get +} {0.6} +test scale-6.9 {ComputeFormat procedure} { + .s configure -from .01 -to .1 -resolution .01 + .s set .06 + .s get +} {0.06} +test scale-6.10 {ComputeFormat procedure} { + .s configure -from .001 -to .01 -resolution .001 + .s set .006 + .s get +} {0.006} +test scale-6.11 {ComputeFormat procedure} { + .s configure -from .0001 -to .001 -resolution .0001 + .s set .0006 + .s get +} {0.0006} +test scale-6.12 {ComputeFormat procedure} { + .s configure -from .00001 -to .0001 -resolution .00001 + .s set .00006 + .s get +} {0.00006} +test scale-6.13 {ComputeFormat procedure} { + .s configure -from .000001 -to .00001 -resolution .000001 + .s set .000006 + .s get +} {6.0e-06} +test scale-6.14 {ComputeFormat procedure} { + .s configure -to .00001 -from .0001 -resolution .00001 + .s set .00006 + .s get +} {0.00006} +test scale-6.15 {ComputeFormat procedure} { + .s configure -to .000001 -from .00001 -resolution .000001 + .s set .000006 + .s get +} {6.0e-06} +test scale-6.16 {ComputeFormat procedure} { + .s configure -from .00001 -to .0001 -resolution .00001 -digits 1 + .s set .00006 + .s get +} {6e-05} +test scale-6.17 {ComputeFormat procedure} { + .s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3 + .s set 49300000 + .s get +} {50000000} +test scale-6.18 {ComputeFormat procedure} { + .s configure -length 200 -from 0 -to 10 -resolution 0 -digits 0 + .s set .111111111 + .s get +} {0.11} +test scale-6.19 {ComputeFormat procedure} { + .s configure -length 200 -from 1000 -to 1002 -resolution 0 -digits 0 + .s set 1001.23456789 + .s get +} {1001.23} +test scale-6.20 {ComputeFormat procedure} { + .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 0 + .s set 1001.23456789 + .s get +} {1001.235} + +test scale-7.1 {ComputeScaleGeometry procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 10 -label "Short" -orient vertical -length 5i + pack .s + update + list [winfo reqwidth .s] [winfo reqheight .s] +} {88 458} +test scale-7.2 {ComputeScaleGeometry procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 1000 -label "Long string" -orient vertical -tick 200 + pack .s + update + list [winfo reqwidth .s] [winfo reqheight .s] +} {168 108} +test scale-7.3 {ComputeScaleGeometry procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -width 10 \ + -sliderlength 10 + pack .s + update + list [winfo reqwidth .s] [winfo reqheight .s] +} {22 108} +test scale-7.4 {ComputeScaleGeometry procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -bd 5 \ + -relief sunken + pack .s + update + list [winfo reqwidth .s] [winfo reqheight .s] +} {39 114} +test scale-7.5 {ComputeScaleGeometry procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 10 -label "Short" -orient horizontal -length 5i + pack .s + update + list [winfo reqwidth .s] [winfo reqheight .s] +} {458 61} +test scale-7.6 {ComputeScaleGeometry procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 1000 -label "Long string" -orient horizontal \ + -tick 500 + pack .s + update + list [winfo reqwidth .s] [winfo reqheight .s] +} {108 79} +test scale-7.7 {ComputeScaleGeometry procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 1000 -orient horizontal -showvalue 0 + pack .s + update + list [winfo reqwidth .s] [winfo reqheight .s] +} {108 27} +test scale-7.8 {ComputeScaleGeometry procedure} { + catch {destroy .s} + scale .s -from 0 -to 1000 -orient horizontal -showvalue 0 -bd 5 \ + -relief raised -highlightthickness 2 + pack .s + update + list [winfo reqwidth .s] [winfo reqheight .s] +} {114 39} + +test scale-8.1 {ScaleElement procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300 + pack .s + .s set 30 + update + list [.s identify 53 52] [.s identify 54 52] [.s identify 70 52] \ + [.s identify 71 52] +} {{} trough1 trough1 {}} +test scale-8.2 {ScaleElement procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300 + pack .s + .s set 30 + update + list [.s identify 60 2] [.s identify 60 3] [.s identify 60 302] \ + [.s identify 60 303] +} {{} trough1 trough2 {}} +test scale-8.3 {ScaleElement procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300 + pack .s + .s set 30 + update + list [.s identify 60 83] [.s identify 60 84] [.s identify 60 113] \ + [.s identify 60 114] \ +} {trough1 slider slider trough2} +test scale-8.4 {ScaleElement procedure} { + catch {destroy .s} + scale .s -from 0 -to 100 -orient vertical -bd 4 -width 10 \ + -highlightthickness 1 -length 300 -showvalue 0 + pack .s + .s set 30 + update + list [.s identify 4 40] [.s identify 5 40] [.s identify 22 40] \ + [.s identify 23 40] \ +} {{} trough1 trough1 {}} +test scale-8.5 {ScaleElement procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 100 -orient horizontal -bd 1 \ + -highlightthickness 2 -tick 20 -sliderlength 20 \ + -length 200 -label Test + pack .s + .s set 30 + update + list [.s identify 150 36] [.s identify 150 37] [.s identify 150 53] \ + [.s identify 150 54] +} {{} trough2 trough2 {}} +test scale-8.6 {ScaleElement procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 100 -orient horizontal -bd 2 \ + -highlightthickness 1 -tick 20 -length 200 + pack .s + .s set 30 + update + list [.s identify 150 20] [.s identify 150 21] [.s identify 150 39] \ + [.s identify 150 40] +} {{} trough2 trough2 {}} +test scale-8.7 {ScaleElement procedure} { + catch {destroy .s} + scale .s -from 0 -to 100 -orient horizontal -bd 4 -highlightthickness 2 \ + -length 200 -width 10 -showvalue 0 + pack .s + .s set 30 + update + list [.s identify 30 5] [.s identify 30 6] [.s identify 30 23] \ + [.s identify 30 24] +} {{} trough1 trough1 {}} +test scale-8.8 {ScaleElement procedure} { + catch {destroy .s} + scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \ + -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0 + pack .s + .s set 30 + update + list [.s identify 2 28] [.s identify 3 28] [.s identify 202 28] \ + [.s identify 203 28] +} {{} trough1 trough2 {}} +test scale-8.9 {ScaleElement procedure} { + catch {destroy .s} + scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \ + -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0 + pack .s + .s set 80 + update + list [.s identify 145 28] [.s identify 146 28] [.s identify 165 28] \ + [.s identify 166 28] +} {trough1 slider slider trough2} + +catch {destroy .s} +scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 +pack .s +update +test scale-9.1 {PixelToValue procedure} { + .s get 46 0 +} 0 +test scale-9.2 {PixelToValue procedure} { + .s get -10 9 +} 0 +test scale-9.3 {PixelToValue procedure} { + .s get -10 12 +} 1 +test scale-9.4 {PixelToValue procedure} { + .s get -10 46 +} 35 +test scale-9.5 {PixelToValue procedure} { + .s get -10 110 +} 99 +test scale-9.6 {PixelToValue procedure} { + .s get -10 111 +} 100 +test scale-9.7 {PixelToValue procedure} { + .s get -10 112 +} 100 +test scale-9.8 {PixelToValue procedure} { + .s get -10 154 +} 100 +.s configure -orient horizontal +update +test scale-9.9 {PixelToValue procedure} { + .s get 76 152 +} 65 + +test scale-10.1 {ValueToPixel procedure} {fonts} { + catch {destroy .s} + scale .s -from 0 -to 100 -sliderlength 20 -length 124 -bd 2 \ + -orient horizontal -label Test -tick 20 + pack .s + update + list [.s coords -10] [.s coords 40] [.s coords 1000] +} {{16 47} {56 47} {116 47}} +test scale-10.2 {ValueToPixel procedure} {fonts} { + catch {destroy .s} + scale .s -from 100 -to 0 -sliderlength 20 -length 122 -bd 1 \ + -orient vertical -label Test -tick 20 + pack .s + update + list [.s coords -10] [.s coords 40] [.s coords 1000] +} {{62 114} {62 74} {62 14}} + +test scale-11.1 {ScaleEventProc procedure} { + proc killScale value { + global x + if {$value > 30} { + destroy .s1 + lappend x [winfo exists .s1] [info commands .s1] + } + } + catch {destroy .s1} + set x initial + scale .s1 -from 0 -to 100 -command killScale + .s1 set 20 + pack .s1 + update idletasks + lappend x [winfo exists .s1] + .s1 set 40 + update idletasks + rename killScale {} + set x +} {initial 1 0 {}} +test scale-11.2 {ScaleEventProc procedure} { + eval destroy [winfo children .] + scale .s1 -bg #543210 + rename .s1 .s2 + set x {} + lappend x [winfo children .] + lappend x [.s2 cget -bg] + destroy .s1 + lappend x [info command .s*] [winfo children .] +} {.s1 #543210 {} {}} + +test scale-12.1 {ScaleCmdDeletedProc procedure} { + eval destroy [winfo children .] + scale .s1 + rename .s1 {} + list [info command .s*] [winfo children .] +} {{} {}} + +catch {destroy .s} +scale .s -from 0 -to 100 -command {set x} -variable y +pack .s +update +proc varTrace args { + global traceInfo + set traceInfo $args +} +test scale-13.1 {SetScaleValue procedure} { + set x xyzzy + .s set 44 + set result [list $x $y] + update + lappend result $x $y +} {xyzzy 44 44 44} +test scale-13.2 {SetScaleValue procedure} { + .s set -3 + .s get +} 0 +test scale-13.3 {SetScaleValue procedure} { + .s set 105 + .s get +} 100 +.s configure -from 100 -to 0 +test scale-13.4 {SetScaleValue procedure} { + .s set -3 + .s get +} 0 +test scale-13.5 {SetScaleValue procedure} { + .s set 105 + .s get +} 100 +test scale-13.6 {SetScaleValue procedure} { + .s set 50 + update + trace variable y w varTrace + set traceInfo empty + set x untouched + .s set 50 + update + list $x $traceInfo +} {untouched empty} + +catch {destroy .s} +scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 -orient horizontal +pack .s +update +.s configure -resolution 4.0 +update +test scale-14.1 {RoundToResolution procedure} { + .s get 84 152 +} 72 +test scale-14.2 {RoundToResolution procedure} { + .s get 86 152 +} 76 +.s configure -from 100 -to 0 +update +test scale-14.3 {RoundToResolution procedure} { + .s get 84 152 +} 28 +test scale-14.4 {RoundToResolution procedure} { + .s get 86 152 +} 24 +.s configure -from -100 -to 0 +update +test scale-14.5 {RoundToResolution procedure} { + .s get 84 152 +} -28 +test scale-14.6 {RoundToResolution procedure} { + .s get 86 152 +} -24 +.s configure -from 0 -to -100 +update +test scale-14.7 {RoundToResolution procedure} { + .s get 84 152 +} -72 +test scale-14.8 {RoundToResolution procedure} { + .s get 86 152 +} -76 +.s configure -from 0 -to 2.25 -resolution 0 +update +test scale-14.9 {RoundToResolution procedure} { + .s get 84 152 +} 1.64 +test scale-14.10 {RoundToResolution procedure} { + .s get 86 152 +} 1.69 +.s configure -from 0 -to 225 -resolution 0 -digits 5 +update +test scale-14.11 {RoundToResolution procedure} { + .s get 84 152 +} 164.25 +test scale-14.12 {RoundToResolution procedure} { + .s get 86 152 +} 168.75 + +test scale-15.1 {ScaleVarProc procedure} { + catch {destroy .s} + set y -130 + scale .s -from 0 -to -200 -variable y -orient horizontal -length 150 + pack .s + set y +} -130 +test scale-15.2 {ScaleVarProc procedure} { + catch {destroy .s} + set y -130 + scale .s -from -200 -to 0 -variable y -orient horizontal -length 150 + pack .s + set y -87 + .s get +} -87 +test scale-15.3 {ScaleVarProc procedure} { + catch {destroy .s} + set y -130 + scale .s -from -200 -to 0 -variable y -orient horizontal -length 150 + pack .s + list [catch {set y 40q} msg] $msg [.s get] +} {1 {can't set "y": can't assign non-numeric value to scale variable} -130} +test scale-15.4 {ScaleVarProc procedure} { + catch {destroy .s} + set y 1 + scale .s -from 1 -to 0 -variable y -orient horizontal -length 150 + pack .s + list [catch {set y x} msg] $msg [.s get] +} {1 {can't set "y": can't assign non-numeric value to scale variable} 1} +test scale-15.5 {ScaleVarProc procedure, variable deleted} { + catch {destroy .s} + set y 6 + scale .s -from 10 -to 0 -variable y -orient horizontal -length 150 \ + -command "set x" + pack .s + update + set x untouched + unset y + update + list [catch {set y} msg] $msg [.s get] $x +} {0 6 6 untouched} +test scale-15.6 {ScaleVarProc procedure, don't call -command} { + catch {destroy .s} + set y 6 + scale .s -from 0 -to 100 -variable y -orient horizontal -length 150 \ + -command "set x" + pack .s + update + set x untouched + set y 60 + update + list $x [.s get] +} {untouched 60} + +set l [interp hidden] +eval destroy [winfo children .] + +test scale-16.1 {scale widget vs hidden commands} { + catch {destroy .s} + scale .s + interp hide {} .s + destroy .s + list [winfo children .] [interp hidden] +} [list {} $l] + +catch {destroy .s} +option clear diff --git a/tests/scrollbar.test b/tests/scrollbar.test new file mode 100644 index 0000000..9242acb --- /dev/null +++ b/tests/scrollbar.test @@ -0,0 +1,665 @@ +# This file is a Tcl script to test out scrollbar widgets and +# the "scrollbar" command of Tk. It is organized in the standard +# fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) scrollbar.test 1.33 97/08/13 17:37:19 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . +update + +proc scroll args { + global scrollInfo + set scrollInfo $args +} + +proc getTroughSize {w} { + global tcl_platform + if {$tcl_platform(platform) == "windows"} { + if [string match v* [$w cget -orient]] { + return [expr [winfo height $w] - 2*[testmetrics cyvscroll]] + } else { + return [expr [winfo width $w] - 2*[testmetrics cxhscroll]] + } + } else { + if [string match v* [$w cget -orient]] { + return [expr [winfo height $w] \ + - ([winfo width $w] \ + - [$w cget -highlightthickness] \ + - [$w cget -bd] + 1)*2] + } else { + return [expr [winfo width $w] \ + - ([winfo height $w] \ + - [$w cget -highlightthickness] \ + - [$w cget -bd] + 1)*2] + } + } +} + +# XXX Note: this test file is woefully incomplete. Right now there are +# only bits and pieces of tests. Please make this file more complete +# as you fix bugs and add features. + +foreach {width height} [wm minsize .] { + set height [expr ($height < 200) ? 200 : $height] + set width [expr ($width < 1) ? 1 : $width] +} + +frame .f -height $height -width $width +pack .f -side left +scrollbar .s +pack .s -side right -fill y +update +set i 1 +foreach test { + {-activebackground #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-activerelief sunken sunken non-existent + {bad relief type "non-existent": must be flat, groove, raised, ridge, solid, or sunken}} + {-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"}} + {-command "set x" {set x} {} {}} + {-elementborderwidth 4 4 badValue {bad screen distance "badValue"}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} + {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}} + {-highlightthickness 6 6 bogus {bad screen distance "bogus"}} + {-highlightthickness -2 0 {} {}} + {-jump true 1 silly {expected boolean value but got "silly"}} + {-orient horizontal horizontal badValue + {bad orientation "badValue": must be vertical or horizontal}} + {-orient horizontal horizontal bogus {bad orientation "bogus": must be vertical or horizontal}} + {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-repeatdelay 140 140 129.3 {expected integer but got "129.3"}} + {-repeatinterval 140 140 129.3 {expected integer but got "129.3"}} + {-takefocus "any string" "any string" {} {}} + {-trough #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] + 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]] + } + .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} { + scrollbar .s + set x "[winfo class .s] [info command .s]" + destroy .s + set x +} {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] + destroy .s + set x +} {.s} + +scrollbar .s -orient vertical -command scroll -highlightthickness 2 -bd 2 +pack .s -side right -fill y +update +test scrollbar-3.1 {ScrollbarWidgetCmd procedure} { + list [catch {.s} msg] $msg +} {1 {wrong # args: should be ".s option ?arg arg ...?"}} +test scrollbar-3.2 {ScrollbarWidgetCmd procedure, "cget" option} { + list [catch {.s cget} msg] $msg +} {1 {wrong # args: should be ".s cget option"}} +test scrollbar-3.3 {ScrollbarWidgetCmd procedure, "cget" option} { + list [catch {.s cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test scrollbar-3.4 {ScrollbarWidgetCmd procedure, "activate" option} { + list [catch {.s activate a b} msg] $msg +} {1 {wrong # args: should be ".s activate element"}} +test scrollbar-3.5 {ScrollbarWidgetCmd procedure, "activate" option} { + .s activate arrow1 + .s activate +} {arrow1} +test scrollbar-3.6 {ScrollbarWidgetCmd procedure, "activate" option} { + .s activate slider + .s activate +} {slider} +test scrollbar-3.7 {ScrollbarWidgetCmd procedure, "activate" option} { + .s activate arrow2 + .s activate +} {arrow2} +test scrollbar-3.8 {ScrollbarWidgetCmd procedure, "activate" option} { + .s activate s + .s activate {} + .s activate +} {} +test scrollbar-3.9 {ScrollbarWidgetCmd procedure, "activate" option} { + list [catch {.s activate trough1} msg] $msg +} {0 {}} +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} {pc} { + list [catch {.s2 cget -bd} msg] $msg +} {0 0} +test scrollbar-3.12 {ScrollbarWidgetCmd procedure, "cget" option} {!pc} { + list [catch {.s2 cget -bd} msg] $msg +} {0 2} +test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} {pc} { + list [catch {.s2 cget -highlightthickness} msg] $msg +} {0 0} +test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} {!pc} { + list [catch {.s2 cget -highlightthickness} msg] $msg +} {0 1} +destroy .s2 +test scrollbar-3.15 {ScrollbarWidgetCmd procedure, "configure" option} { + llength [.s configure] +} {20} +test scrollbar-3.16 {ScrollbarWidgetCmd procedure, "configure" option} { + list [catch {.s configure -bad} msg] $msg +} {1 {unknown option "-bad"}} +test scrollbar-3.17 {ScrollbarWidgetCmd procedure, "configure" option} { + .s configure -orient +} {-orient orient Orient vertical vertical} +test scrollbar-3.18 {ScrollbarWidgetCmd procedure, "configure" option} { + .s configure -orient horizontal + set x [.s cget -orient] + .s configure -orient vertical + set x +} {horizontal} +test scrollbar-3.19 {ScrollbarWidgetCmd procedure, "configure" option} { + list [catch {.s configure -bad worse} msg] $msg +} {1 {unknown option "-bad"}} +test scrollbar-3.20 {ScrollbarWidgetCmd procedure, "delta" option} { + list [catch {.s delta 24} msg] $msg +} {1 {wrong # args: should be ".s delta xDelta yDelta"}} +test scrollbar-3.21 {ScrollbarWidgetCmd procedure, "delta" option} { + list [catch {.s delta 24 35 42} msg] $msg +} {1 {wrong # args: should be ".s delta xDelta yDelta"}} +test scrollbar-3.22 {ScrollbarWidgetCmd procedure, "delta" option} { + list [catch {.s delta silly 24} msg] $msg +} {1 {expected integer but got "silly"}} +test scrollbar-3.23 {ScrollbarWidgetCmd procedure, "delta" option} { + list [catch {.s delta 18 xxyz} msg] $msg +} {1 {expected integer but got "xxyz"}} +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 +} {0} +test scrollbar-3.26 {ScrollbarWidgetCmd procedure, "delta" option} { + .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 [expr -20.0/([getTroughSize .s]-1)]] +test scrollbar-3.28 {ScrollbarWidgetCmd procedure, "delta" option} { + toplevel .t -width 250 -height 100 + wm geom .t +0+0 + 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]] + destroy .t + set result +} {0 1} +test scrollbar-3.29 {ScrollbarWidgetCmd procedure, "fraction" option} { + list [catch {.s fraction 24} msg] $msg +} {1 {wrong # args: should be ".s fraction x y"}} +test scrollbar-3.30 {ScrollbarWidgetCmd procedure, "fraction" option} { + list [catch {.s fraction 24 30 32} msg] $msg +} {1 {wrong # args: should be ".s fraction x y"}} +test scrollbar-3.31 {ScrollbarWidgetCmd procedure, "fraction" option} { + list [catch {.s fraction silly 24} msg] $msg +} {1 {expected integer but got "silly"}} +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 +} {0} +test scrollbar-3.34 {ScrollbarWidgetCmd procedure, "fraction" option} { + .s fraction 0 1000 +} {1} +test scrollbar-3.35 {ScrollbarWidgetCmd procedure, "fraction" option} { + .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 +} {1} +test scrollbar-3.37 {ScrollbarWidgetCmd procedure, "fraction" option} {macOrPc} { + .s fraction 4 [expr 200 - [testmetrics cyvscroll .s]] +} {1} +test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} {unixOnly} { + .s fraction 4 178 +} {0.993711} +test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {pcOnly} { + expr [.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 +scrollbar .t.s -orient horizontal -borderwidth 2 +place .t.s -width 201 +update + +test scrollbar-3.41 {ScrollbarWidgetCmd procedure, "fraction" option} { + .t.s fraction 100 0 +} {0.5} +if {$tcl_platform(platform) == "windows"} { + place configure .t.s -width [expr 2*[testmetrics cxhscroll]+1] +} else { + place configure .t.s -width [expr [winfo reqwidth .t.s] - 4] +} +update +test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} { + .t.s fraction 100 0 +} {0} +destroy .t +test scrollbar-3.43 {ScrollbarWidgetCmd procedure, "get" option} { + list [catch {.s get a} msg] $msg +} {1 {wrong # args: should be ".s get"}} +test scrollbar-3.44 {ScrollbarWidgetCmd procedure, "get" option} { + .s set 100 10 13 14 + .s get +} {100 10 13 14} +test scrollbar-3.45 {ScrollbarWidgetCmd procedure, "get" option} { + .s set 0.6 0.8 + set result {} + foreach element [.s get] { + lappend result [format %.1f $element] + } + set result +} {0.6 0.8} +test scrollbar-3.46 {ScrollbarWidgetCmd procedure, "identify" option} { + list [catch {.s identify 0} msg] $msg +} {1 {wrong # args: should be ".s identify x y"}} +test scrollbar-3.47 {ScrollbarWidgetCmd procedure, "identify" option} { + list [catch {.s identify 0 0 1} msg] $msg +} {1 {wrong # args: should be ".s identify x y"}} +test scrollbar-3.48 {ScrollbarWidgetCmd procedure, "identify" option} { + list [catch {.s identify bogus 2} msg] $msg +} {1 {expected integer but got "bogus"}} +test scrollbar-3.49 {ScrollbarWidgetCmd procedure, "identify" option} { + list [catch {.s identify -1 bogus} msg] $msg +} {1 {expected integer but got "bogus"}} +test scrollbar-3.50 {ScrollbarWidgetCmd procedure, "identify" option} { + .s identify 5 5 +} {arrow1} +test scrollbar-3.51 {ScrollbarWidgetCmd procedure, "identify" option} { + .s identify 5 35 +} {trough1} +test scrollbar-3.52 {ScrollbarWidgetCmd procedure, "identify" option} { + .s set .3 .6 + .s identify 5 80 +} {slider} +test scrollbar-3.53 {ScrollbarWidgetCmd procedure, "identify" option} { + .s identify 5 145 +} {trough2} +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} { + .s identify 0 0 +} {} +test scrollbar-3.57 {ScrollbarWidgetCmd procedure, "set" option} { + list [catch {.s set abc def} msg] $msg +} {1 {expected floating-point number but got "abc"}} +test scrollbar-3.58 {ScrollbarWidgetCmd procedure, "set" option} { + list [catch {.s set 0.6 def} msg] $msg +} {1 {expected floating-point number but got "def"}} +test scrollbar-3.59 {ScrollbarWidgetCmd procedure, "set" option} { + .s set -.2 .3 + set result {} + foreach element [.s get] { + lappend result [format %.1f $element] + } + set result +} {0.0 0.3} +test scrollbar-3.60 {ScrollbarWidgetCmd procedure, "set" option} { + .s set 1.1 .4 + .s get +} {1.0 1.0} +test scrollbar-3.61 {ScrollbarWidgetCmd procedure, "set" option} { + .s set .5 -.3 + .s get +} {0.5 0.5} +test scrollbar-3.62 {ScrollbarWidgetCmd procedure, "set" option} { + .s set .5 87 + .s get +} {0.5 1.0} +test scrollbar-3.63 {ScrollbarWidgetCmd procedure, "set" option} { + .s set .4 .3 + set result {} + foreach element [.s get] { + lappend result [format %.1f $element] + } + set result +} {0.4 0.4} +test scrollbar-3.64 {ScrollbarWidgetCmd procedure, "set" option} { + list [catch {.s set abc def ghi jkl} msg] $msg +} {1 {expected integer but got "abc"}} +test scrollbar-3.65 {ScrollbarWidgetCmd procedure, "set" option} { + list [catch {.s set 1 def ghi jkl} msg] $msg +} {1 {expected integer but got "def"}} +test scrollbar-3.66 {ScrollbarWidgetCmd procedure, "set" option} { + list [catch {.s set 1 2 ghi jkl} msg] $msg +} {1 {expected integer but got "ghi"}} +test scrollbar-3.67 {ScrollbarWidgetCmd procedure, "set" option} { + list [catch {.s set 1 2 3 jkl} msg] $msg +} {1 {expected integer but got "jkl"}} +test scrollbar-3.68 {ScrollbarWidgetCmd procedure, "set" option} { + .s set -10 50 20 30 + .s get +} {0 50 0 0} +test scrollbar-3.69 {ScrollbarWidgetCmd procedure, "set" option} { + .s set 100 -10 20 30 + .s get +} {100 0 20 30} +test scrollbar-3.70 {ScrollbarWidgetCmd procedure, "set" option} { + .s set 100 50 30 20 + .s get +} {100 50 30 30} +test scrollbar-3.71 {ScrollbarWidgetCmd procedure, "set" option} { + list [catch {.s set 1 2 3} msg] $msg +} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}} +test scrollbar-3.72 {ScrollbarWidgetCmd procedure, "set" option} { + list [catch {.s set 1 2 3 4 5} msg] $msg +} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}} +test scrollbar-3.73 {ScrollbarWidgetCmd procedure} { + list [catch {.s bogus} msg] $msg +} {1 {bad option "bogus": must be activate, cget, configure, delta, fraction, get, identify, or set}} +test scrollbar-3.74 {ScrollbarWidgetCmd procedure} { + list [catch {.s c} msg] $msg +} {1 {bad option "c": must be activate, cget, configure, delta, fraction, get, identify, or set}} + +test scrollbar-4.1 {ScrollbarEventProc procedure} { + catch {destroy .s1} + scrollbar .s1 -bg #543210 + rename .s1 .s2 + set x {} + lappend x [winfo exists .s1] + lappend x [.s2 cget -bg] + destroy .s1 + lappend x [info command .s?] [winfo exists .s1] [winfo exists .s2] +} {1 #543210 {} 0 0} + +test scrollbar-5.1 {ScrollbarCmdDeletedProc procedure} { + catch {destroy .s1} + scrollbar .s1 + rename .s1 {} + list [info command .s?] [winfo exists .s1] +} {{} 0} + +catch {destroy .s} +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} { + .s identify 8 3 +} {} +test scrollbar-6.2 {ScrollbarPosition procedure} {macOnly} { + .s identify 8 3 +} {arrow1} +test scrollbar-6.3 {ScrollbarPosition procedure} {macOrUnix} { + .s identify 8 196 +} {} +test scrollbar-6.4 {ScrollbarPosition procedure} {unixOnly} { + .s identify 3 100 +} {} +test scrollbar-6.5 {ScrollbarPosition procedure} {macOnly} { + .s identify 3 100 +} {trough2} +test scrollbar-6.6 {ScrollbarPosition procedure} {macOrUnix} { + .s identify 19 100 +} {} +test scrollbar-6.7 {ScrollbarPosition procedure} { + .s identify [expr [winfo width .s] / 2] -1 +} {} +test scrollbar-6.8 {ScrollbarPosition procedure} { + .s identify [expr [winfo width .s] / 2] [expr [winfo height .s]] +} {} +test scrollbar-6.9 {ScrollbarPosition procedure} { + .s identify -1 [expr [winfo height .s] / 2] +} {} +test scrollbar-6.10 {ScrollbarPosition procedure} { + .s identify [winfo width .s] [expr [winfo height .s] / 2] +} {} + +test scrollbar-6.11 {ScrollbarPosition procedure} {macOrUnix} { + .s identify 8 4 +} {arrow1} +test scrollbar-6.12 {ScrollbarPosition procedure} {unixOnly} { + .s identify 8 19 +} {arrow1} +test scrollbar-6.13 {ScrollbarPosition procedure} {macOnly} { + .s identify 8 19 +} {trough1} +test scrollbar-6.14 {ScrollbarPosition procedure} {pcOnly} { + .s identify [expr [winfo width .s] / 2] 0 +} {arrow1} +test scrollbar-6.15 {ScrollbarPosition procedure} {pcOnly} { + .s identify [expr [winfo width .s] / 2] [expr [testmetrics cyvscroll] - 1] +} {arrow1} + +test scrollbar-6.16 {ScrollbarPosition procedure} {macOrUnix} { + .s identify 8 20 +} {trough1} +test scrollbar-6.17 {ScrollbarPosition procedure} {macOrUnix 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} {pcOnly} { + .s identify [expr [winfo width .s] / 2] [testmetrics cyvscroll] +} {trough1} +test scrollbar-6.19 {ScrollbarPosition procedure} {pcOnly} { + .s identify [expr [winfo width .s] / 2] [expr int(.2 / [.s delta 0 1]) \ + + [testmetrics cyvscroll] - 1] +} {trough1} + +test scrollbar-6.20 {ScrollbarPosition procedure} {macOrUnix} { + .s identify 8 52 +} {slider} +test scrollbar-6.21 {ScrollbarPosition procedure} {macOrUnix 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} {pcOnly} { + .s identify [expr [winfo width .s] / 2] [expr int(.2 / [.s delta 0 1]) \ + + [testmetrics cyvscroll]] +} {slider} +test scrollbar-6.23 {ScrollbarPosition procedure} {pcOnly} { + .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ + + [testmetrics cyvscroll] - 1] +} {slider} + +test scrollbar-6.24 {ScrollbarPosition procedure} {macOrUnix} { + .s identify 8 84 +} {trough2} +test scrollbar-6.25 {ScrollbarPosition procedure} {unixOnly} { + .s identify 8 179 +} {trough2} +test scrollbar-6.26 {ScrollbarPosition procedure} {macOnly} { + .s identify 8 179 +} {arrow2} +test scrollbar-6.27 {ScrollbarPosition procedure} {pcOnly} { + .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ + + [testmetrics cyvscroll]] +} {trough2} +test scrollbar-6.28 {ScrollbarPosition procedure} {pcOnly} { + .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ + - [testmetrics cyvscroll] - 1] +} {trough2} + +test scrollbar-6.29 {ScrollbarPosition procedure} {macOrUnix} { + .s identify 8 180 +} {arrow2} +test scrollbar-6.30 {ScrollbarPosition procedure} {unixOnly} { + .s identify 8 195 +} {arrow2} +test scrollbar-6.31 {ScrollbarPosition procedure} {macOnly} { + .s identify 8 195 +} {} +test scrollbar-6.32 {ScrollbarPosition procedure} {pcOnly} { + .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ + - [testmetrics cyvscroll]] +} {arrow2} +test scrollbar-6.33 {ScrollbarPosition procedure} {pcOnly} { + .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] - 1] +} {arrow2} + +test scrollbar-6.34 {ScrollbarPosition procedure} {macOrUnix} { + .s identify 4 100 +} {trough2} +test scrollbar-6.35 {ScrollbarPosition procedure} {unixOnly} { + .s identify 18 100 +} {trough2} +test scrollbar-6.36 {ScrollbarPosition procedure} {macOnly} { + .s identify 18 100 +} {} +test scrollbar-6.37 {ScrollbarPosition procedure} {pcOnly} { + .s identify 0 100 +} {trough2} +test scrollbar-6.38 {ScrollbarPosition procedure} {pcOnly} { + .s identify [expr [winfo width .s] - 1] 100 +} {trough2} + +catch {destroy .t} +toplevel .t -width 250 -height 150 +wm geometry .t +0+0 +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} { + .t.s identify 4 8 +} {arrow1} +test scrollbar-6.40 {ScrollbarPosition procedure} {pcOnly} { + .t.s identify 0 [expr [winfo height .t.s] / 2] +} {arrow1} +test scrollbar-6.41 {ScrollbarPosition procedure} {unixOnly} { + .t.s identify 82 8 +} {slider} +test scrollbar-6.42 {ScrollbarPosition procedure} {macOnly} { + .t.s identify 82 8 +} {} +test scrollbar-6.43 {ScrollbarPosition procedure} {pcOnly} { + .t.s identify [expr int(.4 / [.t.s delta 1 0]) + [testmetrics cxhscroll] \ + - 1] [expr [winfo height .t.s] / 2] +} {slider} +test scrollbar-6.44 {ScrollbarPosition procedure} {unixOnly} { + .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} { + .t.s identify 100 [expr [winfo height .t.s] - 1] +} {trough2} + +test scrollbar-7.1 {EventuallyRedraw} { + .s configure -orient horizontal + update + set result [.s cget -orient] + .s configure -orient vertical + update + lappend result [.s cget -orient] +} {horizontal vertical} + +catch {destroy .t} +toplevel .t +wm geometry .t +0+0 +test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} { + proc doit {args} { destroy .t.f } + proc bgerror {args} {} + frame .t.f + scrollbar .t.f.s -command doit + pack .t.f -fill both -expand 1 + pack .t.f.s -fill y -expand 1 -side right + wm geometry .t 100x100 + .t.f.s set 0 .5 + update + set result [winfo exists .t.f.s] + event generate .t.f.s <ButtonPress> -button 1 -x [expr [winfo width .t.f.s] / 2] -y 5 + update + lappend result [winfo exists .t.f.s] [winfo exists .t.f] + rename bgerror {} + set result +} {1 0 0} +test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} { + proc doit {args} { destroy .t.f.s } + proc bgerror {args} {} + frame .t.f + scrollbar .t.f.s -command doit + pack .t.f -fill both -expand 1 + pack .t.f.s -fill y -expand 1 -side right + wm geometry .t 100x100 + .t.f.s set 0 .5 + update + set result [winfo exists .t.f.s] + event generate .t.f.s <ButtonPress> -button 1 -x [expr [winfo width .t.f.s] / 2] -y 5 + update + lappend result [winfo exists .t.f.s] [winfo exists .t.f] + rename bgerror {} + set result +} {1 0 1} + +set l [interp hidden] +eval destroy [winfo children .] + +test scrollbar-9.1 {scrollbar widget vs hidden commands} { + catch {destroy .s} + scrollbar .s + interp hide {} .s + destroy .s + list [winfo children .] [interp hidden] +} [list {} $l] + +catch {destroy .s} +catch {destroy .t} +concat {} diff --git a/tests/select.test b/tests/select.test new file mode 100644 index 0000000..82db030 --- /dev/null +++ b/tests/select.test @@ -0,0 +1,987 @@ +# This file is a Tcl script to test out Tk's selection management code, +# especially the "selection" command. It is organized in the standard +# fashion for Tcl tests. +# +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) select.test 1.17 96/12/09 17:25:48 + +# +# Note: Multiple display selection handling will only be tested if the +# environment variable TK_ALT_DISPLAY is set to an alternate display. +# + +if {[string compare test [info procs test]] == 1} { + source defs +} + +eval destroy [winfo child .] + +global longValue selValue selInfo + +set selValue {} +set selInfo {} + +proc handler {type offset count} { + global selValue selInfo + lappend selInfo $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] +} + +proc errIncrHandler {type offset count} { + global selValue selInfo pass + if {$offset == 4000} { + if {$pass == 0} { + # Just sizing the selection; don't do anything here. + set pass 1 + } else { + # Fetching the selection; wait long enough to cause a timeout. + after 6000 + } + } + lappend selInfo $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] +} + +proc errHandler args { + error "selection handler aborted" +} + +proc badHandler {path type offset count} { + global selValue selInfo + selection handle -type $type $path {} + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] +} +proc reallyBadHandler {path type offset count} { + global selValue selInfo pass + if {$offset == 4000} { + if {$pass == 0} { + set pass 1 + } else { + selection handle -type $type $path {} + } + } + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] +} + +# Eliminate any existing selection on the screen. This is needed in case +# there is a selection in some other application, in order to prevent races +# from causing false errors in the tests below. + +selection clear . +after 1500 + +# common setup code +proc setup {{path .f1} {display {}}} { + catch {destroy $path} + if {$display == {}} { + frame $path + } else { + toplevel $path -screen $display + wm geom $path +0+0 + } + selection own $path +} + +# set up a very large buffer to test INCR retrievals +set longValue "" +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} { + set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14 + 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 +} + +# Now we start the main body of the test code + +test select-1.1 {Tk_CreateSelHandler procedure} { + setup + lsort [selection get TARGETS] +} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} +test select-1.2 {Tk_CreateSelHandler procedure} { + setup + selection handle .f1 {handler TEST} TEST + lsort [selection get TARGETS] +} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} +test select-1.3 {Tk_CreateSelHandler procedure} { + global selValue selInfo + setup + selection handle .f1 {handler TEST} TEST + set selValue "Test value" + set selInfo "" + list [selection get TEST] $selInfo +} {{Test value} {TEST 0 4000}} +test select-1.4 {Tk_CreateSelHandler procedure} { + 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} +test select-1.5 {Tk_CreateSelHandler procedure} { + global selValue selInfo + setup + selection handle .f1 {handler TEST} TEST + selection handle .f1 {handler STRING} + set selValue "" + set selInfo "" + list [selection get] $selInfo +} {{} {STRING 0 4000}} +test select-1.6 {Tk_CreateSelHandler procedure} { + global selValue selInfo + setup + selection handle .f1 {handler TEST} TEST + selection handle .f1 {handler STRING} + set selValue "" + set selInfo "" + selection get + selection get -type TEST + selection handle .f1 {handler TEST2} TEST + 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 {Tk_CreateSelHandler procedure} { + 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]] +} {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-1.8 {Tk_CreateSelHandler procedure} { + setup + selection handle -format INTEGER -type TEST .f1 {handler TEST} + lsort [selection get TARGETS] +} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} + +############################################################################## + +test select-2.1 {Tk_DeleteSelHandler procedure} { + setup + 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.2 {Tk_DeleteSelHandler procedure} { + setup + 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.3 {Tk_DeleteSelHandler procedure} { + setup + selection own -selection CLIPBOARD .f1 + 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} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-2.4 {Tk_DeleteSelHandler procedure} { + setup + selection handle .f1 {handler STRING} + list [selection handle .f1 {}] [selection handle .f1 {}] +} {{} {}} + +############################################################################## + +test select-3.1 {Tk_OwnSelection procedure} { + setup + selection own +} {.f1} +test select-3.2 {Tk_OwnSelection procedure} { + setup .f1 + set result [selection own] + setup .f2 + lappend result [selection own] +} {.f1 .f2} +test select-3.3 {Tk_OwnSelection procedure} { + setup .f1 + setup .f2 + selection own -selection CLIPBOARD .f1 + list [selection own] [selection own -selection CLIPBOARD] +} {.f2 .f1} +test select-3.4 {Tk_OwnSelection procedure} { + global lostSel + setup + set lostSel {owned} + selection own -command { set lostSel {lost} } .f1 + selection clear .f1 + set lostSel +} {lost} +test select-3.5 {Tk_OwnSelection procedure} { + global lostSel + setup .f1 + setup .f2 + set lostSel {owned} + selection own -command { set lostSel {lost1} } .f1 + selection own -command { set lostSel {lost2} } .f2 + list $lostSel [selection own] +} {lost1 .f2} +test select-3.6 {Tk_OwnSelection procedure} { + global lostSel + setup + set lostSel {owned} + selection own -command { set lostSel {lost1} } .f1 + selection own -command { set lostSel {lost2} } .f1 + set result $lostSel + selection clear .f1 + lappend result $lostSel +} {owned lost2} +test select-3.7 {Tk_OwnSelection procedure} {unixOnly} { + global lostSel + setup + setupbg + set lostSel {owned} + selection own -command { set lostSel {lost1} } .f1 + update + set result {} + lappend result [dobg { selection own . }] + lappend result [dobg {selection own}] + update + cleanupbg + lappend result $lostSel +} {{} . lost1} +# check reentrancy on selection replacement +test select-3.8 {Tk_OwnSelection procedure} { + setup + selection own -selection CLIPBOARD -command { destroy .f1 } .f1 + selection own -selection CLIPBOARD . +} {} +test select-3.9 {Tk_OwnSelection procedure} { + setup .f2 + setup .f1 + selection own -selection CLIPBOARD -command { destroy .f2 } .f1 + selection own -selection CLIPBOARD .f2 +} {} + +# multiple display tests +if {[info exists env(TK_ALT_DISPLAY)]} { + + test select-3.10 {Tk_OwnSelection procedure} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + list [selection own -displayof .f1] [selection own -displayof .f2] + } {.f1 .f2} + test select-3.11 {Tk_OwnSelection procedure} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + setupbg + update + set result "" + lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] + lappend result [selection own -displayof .f1] \ + [selection own -displayof .f2] + cleanupbg + set result + } {{} .f1 {}} + +} +############################################################################## + +test select-4.1 {Tk_ClearSelection procedure} { + setup + set result [selection own] + selection clear .f1 + lappend result [selection own] +} {.f1 {}} +test select-4.2 {Tk_ClearSelection procedure} { + setup + selection own -selection CLIPBOARD .f1 + selection clear .f1 + selection own -selection CLIPBOARD +} {.f1} +test select-4.3 {Tk_ClearSelection procedure} { + setup + list [selection clear .f1] [selection clear .f1] +} {{} {}} +test select-4.4 {Tk_ClearSelection procedure} {unixOnly} { + global lostSel + setup + setupbg + set lostSel {owned} + selection own -command { set lostSel {lost1} } .f1 + update + set result {} + lappend result [dobg {selection clear; update}] + update + cleanupbg + lappend result [selection own] +} {{} {}} + +# multiple display tests +if {[info exists env(TK_ALT_DISPLAY)]} { + test select-4.5 {Tk_ClearSelection procedure} { + global lostSel lostSel2 + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + set lostSel {owned} + set lostSel2 {owned2} + selection own -command { set lostSel {lost1} } .f1 + selection own -command { set lostSel2 {lost2} } .f2 + update + selection clear -displayof .f2 + update + list $lostSel $lostSel2 + } {owned lost2} + test select-4.6 {Tk_ClearSelection procedure} {unixOnly} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + setupbg + set lostSel {owned} + set lostSel2 {owned2} + selection own -command { set lostSel {lost1} } .f1 + selection own -command { set lostSel2 {lost2} } .f2 + update + set result "" + lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] + lappend result [selection own -displayof .f1] \ + [selection own -displayof .f2] $lostSel $lostSel2 + cleanupbg + set result + } {{} .f1 {} owned lost2} + +} +############################################################################## + +test select-5.1 {Tk_GetSelection procedure} { + setup + list [catch {selection get TEST} msg] $msg +} {1 {PRIMARY selection doesn't exist or form "TEST" not defined}} +test select-5.2 {Tk_GetSelection procedure} { + setup + selection get TK_WINDOW +} {.f1} +test select-5.3 {Tk_GetSelection procedure} { + setup + selection handle -selection PRIMARY .f1 {handler TEST} TEST + set selValue "Test value" + set selInfo "" + list [selection get TEST] $selInfo +} {{Test value} {TEST 0 4000}} +test select-5.4 {Tk_GetSelection procedure} { + setup + selection handle .f1 ERROR errHandler + list [catch {selection get ERROR} msg] $msg +} {1 {PRIMARY selection doesn't exist or form "ERROR" not defined}} +test select-5.5 {Tk_GetSelection procedure} { + setup + set selValue $longValue + set selInfo "" + selection handle .f1 {handler STRING} + list [selection get] $selInfo +} "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000}" +test select-5.6 {Tk_GetSelection procedure} { + proc weirdHandler {type offset count} { + selection handle .f1 {} + handler $type $offset $count + } + setup + set selValue $longValue + set selInfo "" + selection handle .f1 {weirdHandler STRING} + list [catch {selection get} msg] $msg +} {1 {PRIMARY selection doesn't exist or form "STRING" not defined}} +test select-5.7 {Tk_GetSelection procedure} { + proc weirdHandler {type offset count} { + destroy .f1 + handler $type $offset $count + } + setup + set selValue "Test Value" + set selInfo "" + selection handle .f1 {weirdHandler STRING} + list [catch {selection get} msg] $msg +} {1 {PRIMARY selection doesn't exist or form "STRING" not defined}} +test select-5.8 {Tk_GetSelection procedure} { + proc weirdHandler {type offset count} { + selection clear + handler $type $offset $count + } + setup + set selValue $longValue + set selInfo "" + 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} { + setup + setupbg + selection handle -selection PRIMARY .f1 {handler TEST} TEST + update + set selValue "Test value" + set selInfo "" + set result "" + lappend result [dobg {selection get TEST}] + cleanupbg + lappend result $selInfo +} {{Test value} {TEST 0 4000}} +test select-5.10 {Tk_GetSelection procedure} {unixOnly} { + setup + setupbg + selection handle -selection PRIMARY .f1 {handler TEST} TEST + update + set selValue "Test value" + set selInfo "" + selection own .f1 + set result "" + fileevent $fd readable {} + puts $fd {catch {selection get TEST} msg; update; puts $msg; flush stdout} + flush $fd + lappend result [gets $fd] + cleanupbg + lappend result $selInfo +} {{selection owner didn't respond} {}} + +# multiple display tests +if {[info exists env(TK_ALT_DISPLAY)]} { + test select-5.11 {Tk_GetSelection procedure} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + selection handle -selection PRIMARY .f1 {handler TEST} TEST + selection handle -selection PRIMARY .f2 {handler TEST2} TEST + set selValue "Test value" + set selInfo "" + set result [list [selection get TEST] $selInfo] + set selValue "Test value2" + set selInfo "" + lappend result [selection get -displayof .f2 TEST] $selInfo + } {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}} + test select-5.12 {Tk_GetSelection procedure} { + global lostSel lostSel2 + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + selection handle -selection PRIMARY .f1 {handler TEST} TEST + selection handle -selection PRIMARY .f2 {} TEST + set selValue "Test value" + set selInfo "" + set result [list [catch {selection get TEST} msg] $msg $selInfo] + set selValue "Test value2" + set selInfo "" + 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} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + setupbg + selection handle -selection PRIMARY .f1 {handler TEST} TEST + selection own .f1 + selection handle -selection PRIMARY .f2 {handler TEST2} TEST + selection own .f2 + set selValue "Test value" + set selInfo "" + update + set result "" + lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] + set selValue "Test value2" + lappend result [dobg "selection get TEST"] + cleanupbg + lappend result $selInfo + } {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}} + test select-5.14 {Tk_GetSelection procedure} {unixOnly} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + setupbg + selection handle -selection PRIMARY .f1 {handler TEST} TEST + selection own .f1 + selection handle -selection PRIMARY .f2 {} TEST + selection own .f2 + set selValue "Test value" + set selInfo "" + update + set result "" + lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] + set selValue "Test value2" + lappend result [dobg "selection get TEST"] + cleanupbg + lappend result $selInfo + } {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}} + +} +############################################################################## + +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 +} {1 {value for "-selection" missing}} +test select-6.3 {Tk_SelectionCmd procedure} { + setup + selection own . + set result [selection own] + selection clear -displayof .f1 + lappend result [selection own] +} {. {}} +test select-6.4 {Tk_SelectionCmd procedure} { + setup + selection own -selection CLIPBOARD .f1 + set result [list [selection own] [selection own -selection CLIPBOARD]] + selection clear -selection CLIPBOARD .f1 + lappend result [selection own] [selection own -selection CLIPBOARD] +} {.f1 .f1 .f1 {}} +test select-6.5 {Tk_SelectionCmd procedure} { + setup + selection own -selection CLIPBOARD . + set result [list [selection own] [selection own -selection CLIPBOARD]] + selection clear -selection CLIPBOARD -displayof .f1 + lappend result [selection own] [selection own -selection CLIPBOARD] +} {.f1 . .f1 {}} +test select-6.6 {Tk_SelectionCmd procedure} { + list [catch {selection clear -badopt foo} cmd] $cmd +} {1 {unknown option "-badopt"}} +test select-6.7 {Tk_SelectionCmd procedure} { + list [catch {selection clear -selectionfoo foo} cmd] $cmd +} {1 {unknown option "-selectionfoo"}} +test select-6.8 {Tk_SelectionCmd procedure} { + catch {destroy .f2} + list [catch {selection clear -displayof .f2} cmd] $cmd +} {1 {bad window path name ".f2"}} +test select-6.9 {Tk_SelectionCmd procedure} { + catch {destroy .f2} + list [catch {selection clear .f2} cmd] $cmd +} {1 {bad window path name ".f2"}} +test select-6.10 {Tk_SelectionCmd procedure} { + setup + set result [selection own -selection PRIMARY] + selection clear + lappend result [selection own -selection PRIMARY] +} {.f1 {}} +test select-6.11 {Tk_SelectionCmd procedure} { + setup + selection own -selection CLIPBOARD .f1 + set result [selection own -selection CLIPBOARD] + selection clear -selection CLIPBOARD + lappend result [selection own -selection CLIPBOARD] +} {.f1 {}} +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 +} {1 {value for "-selection" missing}} +test select-6.14 {Tk_SelectionCmd procedure} { + global selValue selInfo + setup + selection handle .f1 {handler TEST} + set selValue "Test value" + set selInfo "" + list [selection get -displayof .f1] $selInfo +} {{Test value} {TEST 0 4000}} +test select-6.15 {Tk_SelectionCmd procedure} { + global selValue selInfo + setup + selection handle .f1 {handler STRING} + selection handle -selection CLIPBOARD .f1 {handler TEST} + selection own -selection CLIPBOARD .f1 + set selValue "Test value" + set selInfo "" + list [selection get -selection CLIPBOARD] $selInfo +} {{Test value} {TEST 0 4000}} +test select-6.16 {Tk_SelectionCmd procedure} { + global selValue selInfo + setup + selection handle -type TEST .f1 {handler TEST} + selection handle -type STRING .f1 {handler STRING} + set selValue "Test value" + set selInfo "" + list [selection get -type TEST] $selInfo +} {{Test value} {TEST 0 4000}} +test select-6.17 {Tk_SelectionCmd procedure} { + list [catch {selection get -badopt foo} cmd] $cmd +} {1 {unknown option "-badopt"}} +test select-6.18 {Tk_SelectionCmd procedure} { + list [catch {selection get -selectionfoo foo} cmd] $cmd +} {1 {unknown option "-selectionfoo"}} +test select-6.19 {Tk_SelectionCmd procedure} { + catch { destroy .f2 } + list [catch {selection get -displayof .f2} cmd] $cmd +} {1 {bad window path name ".f2"}} +test select-6.20 {Tk_SelectionCmd procedure} { + list [catch {selection get foo bar} cmd] $cmd +} {1 {wrong # args: should be "selection get ?options?"}} +test select-6.21 {Tk_SelectionCmd procedure} { + global selValue selInfo + setup + selection handle -type TEST .f1 {handler TEST} + selection handle -type STRING .f1 {handler STRING} + set selValue "Test value" + 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} { + list [catch {selection handle -selection} cmd] $cmd +} {1 {value for "-selection" missing}} +test select-6.23 {Tk_SelectionCmd procedure} { + global selValue selInfo + setup + set selValue "Test value" + set selInfo "" + list [selection handle -format INTEGER .f1 {handler TEST}] [selection get -displayof .f1] $selInfo +} {{} {Test value} {TEST 0 4000}} +test select-6.24 {Tk_SelectionCmd procedure} { + list [catch {selection handle -badopt foo} cmd] $cmd +} {1 {unknown option "-badopt"}} +test select-6.25 {Tk_SelectionCmd procedure} { + list [catch {selection handle -selectionfoo foo} cmd] $cmd +} {1 {unknown option "-selectionfoo"}} +test select-6.26 {Tk_SelectionCmd procedure} { + list [catch {selection handle} cmd] $cmd +} {1 {wrong # args: should be "selection handle ?options? window command"}} +test select-6.27 {Tk_SelectionCmd procedure} { + list [catch {selection handle .} cmd] $cmd +} {1 {wrong # args: should be "selection handle ?options? window command"}} +test select-6.28 {Tk_SelectionCmd procedure} { + list [catch {selection handle . foo bar baz blat} cmd] $cmd +} {1 {wrong # args: should be "selection handle ?options? window command"}} +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 +} {1 {value for "-selection" missing}} +test select-6.31 {Tk_SelectionCmd procedure} { + setup + selection own . + selection own -displayof .f1 +} {.} +test select-6.32 {Tk_SelectionCmd procedure} { + setup + selection own . + selection own -selection CLIPBOARD .f1 + list [selection own] [selection own -selection CLIPBOARD] +} {. .f1} +test select-6.33 {Tk_SelectionCmd procedure} { + global lostSel + setup + set lostSel owned + selection own -command { set lostSel lost } . + selection own -selection CLIPBOARD .f1 + set result $lostSel + selection own .f1 + lappend result $lostSel +} {owned lost} +test select-6.34 {Tk_SelectionCmd procedure} { + list [catch {selection own -badopt foo} cmd] $cmd +} {1 {unknown option "-badopt"}} +test select-6.35 {Tk_SelectionCmd procedure} { + list [catch {selection own -selectionfoo foo} cmd] $cmd +} {1 {unknown option "-selectionfoo"}} +test select-6.36 {Tk_SelectionCmd procedure} { + catch {destroy .f2} + list [catch {selection own -displayof .f2} cmd] $cmd +} {1 {bad window path name ".f2"}} +test select-6.37 {Tk_SelectionCmd procedure} { + catch {destroy .f2} + list [catch {selection own .f2} cmd] $cmd +} {1 {bad window path name ".f2"}} +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}} + +############################################################################## + +# Check reentrancy on losing selection + +test select-8.1 {TkSelEventProc procedure} {unixOnly} { + setup + setupbg + selection own -selection CLIPBOARD -command { destroy .f1 } .f1 + update + set result [dobg {selection own -selection CLIPBOARD .}] + cleanupbg + set result +} {} + +############################################################################## + +test select-9.1 {SelCvtToX and SelCvtFromX procedures} {unixOnly} { + global selValue selInfo + setup + setupbg + set selValue "1024" + set selInfo "" + selection handle -selection PRIMARY -format INTEGER -type 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 + setup + setupbg + set selValue "1024 0xffff 2048 -2 " + set selInfo "" + selection handle -selection PRIMARY -format INTEGER -type TEST \ + .f1 {handler TEST} + set result "" + 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 + setup + setupbg + set selValue " " + set selInfo "" + selection handle -selection PRIMARY -format INTEGER -type TEST \ + .f1 {handler TEST} + set result "" + 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 + setup + setupbg + set selValue "16 foobar 32" + set selInfo "" + selection handle -selection PRIMARY -format INTEGER -type TEST \ + .f1 {handler TEST} + set result "" + lappend result [dobg {selection get TEST}] + cleanupbg + lappend result $selInfo +} {{0x10 0x0 0x20} {TEST 0 4000}} + +############################################################################## + +# 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} { + setup + setupbg + set selValue "Just a simple test" + set selInfo "" + selection handle .f1 {handler STRING} + update + puts $fd {puts "[catch {selection get} msg] $msg"; puts **DONE**; flush stdout} + flush $fd + after 200 + selection own . + set bgData {} + tkwait variable bgDone + cleanupbg + list $bgData $selInfo +} {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}} +test select-10.2 {ConvertSelection procedure} {unixOnly} { + setup + setupbg + set selValue [string range $longValue 0 3999] + set selInfo "" + selection handle .f1 {handler STRING} + set result "" + lappend result [dobg {selection get}] + 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} { + setup + setupbg + selection handle .f1 ERROR errHandler + set result "" + lappend result [dobg {selection get ERROR}] + cleanupbg + set result +} {{PRIMARY selection doesn't exist or form "ERROR" not defined}} +# testing timers +test select-10.4 {ConvertSelection procedure} {unixOnly} { + setup + setupbg + set selValue $longValue + set selInfo "" + selection handle .f1 {errIncrHandler STRING} + set result "" + set pass 0 + lappend result [dobg {selection get}] + 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} { + setup + setupbg + set selValue "Test value" + set selInfo "" + selection handle -type TEST .f1 { handler TEST } + selection handle -type STRING .f1 { badHandler .f1 STRING } + set result "" + lappend result [dobg {selection get}] + 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} { + proc weirdHandler {type offset count} { + destroy .f1 + handler $type $offset $count + } + setup + setupbg + set selValue $longValue + set selInfo "" + selection handle .f1 {weirdHandler STRING} + set result "" + lappend result [dobg {selection get}] + cleanupbg + lappend result $selInfo +} {{PRIMARY selection doesn't exist or form "STRING" not defined} {STRING 0 4000}} + +############################################################################## + +# testing reentrancy +test select-11.1 {TkSelPropProc procedure} {unixOnly} { + setup + setupbg + set selValue $longValue + set selInfo "" + selection handle -type TEST .f1 { handler TEST } + selection handle -type STRING .f1 { reallyBadHandler .f1 STRING } + set result "" + set pass 0 + lappend result [dobg {selection get}] + cleanupbg + lappend result $selInfo +} {{selection owner didn't respond} {.f1 STRING 0 4000 .f1 STRING 4000 4000 .f1 STRING 8000 4000 .f1 STRING 12000 4000 .f1 STRING 16000 4000 .f1 STRING 0 4000 .f1 STRING 4000 4000}} + +############################################################################## + +# Note, this assumes we are using CurrentTtime +test select-12.1 {DefaultSelection procedure} {unixOnly} { + 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} { + setup + set result [lsort [list [selection get -type TARGETS]]] + setupbg + lappend result [dobg {lsort [selection get -type TARGETS]}] + cleanupbg + set result +} {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-12.3 {DefaultSelection procedure} {unixOnly} { + setup + selection handle .f1 {handler TEST} TEST + set result [list [lsort [selection get -type TARGETS]]] + setupbg + lappend result [dobg {lsort [selection get -type TARGETS]}] + 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} { + setup + set result "" + lappend result [selection get -type TK_APPLICATION] + setupbg + lappend result [dobg {selection get -type TK_APPLICATION}] + cleanupbg + set result +} [list [winfo name .] [winfo name .]] +test select-12.5 {DefaultSelection procedure} {unixOnly} { + setup + set result [selection get -type TK_WINDOW] + setupbg + lappend result [dobg {selection get -type TK_WINDOW}] + cleanupbg + 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" + set selInfo "" + set result [list [selection get TARGETS] $selInfo] + selection handle .f1 {} TARGETS + 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} { + proc badHandler {path type offset count} { + global selValue selInfo abortCount + incr abortCount -1 + if {$abortCount == 0} { + selection handle -type $type $path {} + } + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] + } + setup + setupbg + set selValue $longValue + set selInfo "" + selection handle .f1 {badHandler .f1 STRING} + set result "" + set abortCount 2 + lappend result [dobg {selection get}] + cleanupbg + lappend result $selInfo +} {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}} + +catch {rename weirdHandler {}} +concat diff --git a/tests/send.test b/tests/send.test new file mode 100644 index 0000000..7addb73 --- /dev/null +++ b/tests/send.test @@ -0,0 +1,656 @@ +# This file is a Tcl script to test out the "send" command and the +# other procedures in the file tkSend.c. It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) send.test 1.26 96/12/09 17:26:42 + +if {$tcl_platform(platform) == "macintosh"} { + puts "send is not available on the Mac - skipping tests" + return +} +if {$tcl_platform(platform) == "window"} { + puts "send is not available under Windows - skipping tests" + return +} +if {[auto_execok xhost] == ""} { + puts "xhost application isn't available - skipping tests" + return +} + +if {[info procs test] != "test"} { + source defs +} +if {[info commands testsend] == "testsend"} { + set gotTestCmds 1 +} else { + set gotTestCmds 0 +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# If send is disabled because of inadequate security, don't run any +# of these tests at all. + +setupbg +set app [dobg {tk appname}] +if {[catch {send $app set a 0} msg] == 1} { + if [string match "X server insecure *" $msg] { + puts -nonewline "Your X server is insecure, so \"send\" can't be used;" + puts " skipping \"send\" tests." + cleanupbg + return + } +} +cleanupbg + +# Compute a script that will load Tk into a child interpreter. + +foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + set loadTk "load $pkg" + break + } +} + +# Procedure to create a new application with a given name and class. + +proc newApp {screen name class} { + global loadTk + interp create $name + $name eval [list set argv [list -display $screen -name $name -class $class]] + eval $loadTk $name +} + +set name [tk appname] +if $gotTestCmds { + set registry [testsend prop root InterpRegistry] + set commId [lindex [testsend prop root InterpRegistry] 0] +} +tk appname tktest +catch {send t_s_1 destroy .} +catch {send t_s_2 destroy .} + +if $gotTestCmds { + test send-1.1 {RegOpen procedure, bogus property} { + testsend bogus + set result [winfo interps] + tk appname tktest + list $result [winfo interps] + } {{} tktest} + test send-1.2 {RegOpen procedure, bogus property} { + testsend prop root InterpRegistry {} + set result [winfo interps] + tk appname tktest + list $result [winfo interps] + } {{} tktest} + test send-1.3 {RegOpen procedure, bogus property} { + testsend prop root InterpRegistry abcdefg + tk appname tktest + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " tktest\nabcdefg\n" + + frame .f -width 1 -height 1 + set id [string range [winfo id .f] 2 end] + test send-2.1 {RegFindName procedure} { + testsend prop root InterpRegistry {} + list [catch {send foo bar} msg] $msg + } {1 {no application named "foo"}} + test send-2.2 {RegFindName procedure} { + testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n" + tk appname foo + } {foo #2} + test send-2.3 {RegFindName procedure} { + testsend prop root InterpRegistry "gyz foo\n" + tk appname foo + } {foo} + test send-2.4 {RegFindName procedure} { + testsend prop root InterpRegistry "${id}z foo\n" + tk appname foo + } {foo} + + test send-3.1 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\n012345 gorp\n12345 foo\n" + test send-3.2 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\n012345 gorp\n23456 tktest\n" + test send-3.3 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\n12345 bar\n23456 tktest\n" + test send-3.4 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "foo" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\nfoo\n" + test send-3.5 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\n" + + test send-4.1 {RegAddName procedure} { + testsend prop root InterpRegistry "" + tk appname bar + testsend prop root InterpRegistry + } "$commId bar\n" + test send-4.2 {RegAddName procedure} { + testsend prop root InterpRegistry "abc def" + tk appname bar + tk appname foo + testsend prop root InterpRegistry + } "$commId foo\nabc def\n" + + # Previous checks should already cover the Regclose procedure. + + test send-5.1 {ValidateName procedure} { + testsend prop root InterpRegistry "123 abc\n" + winfo interps + } {} + test send-5.2 {ValidateName procedure} { + testsend prop root InterpRegistry "$id Hi there" + winfo interps + } {{Hi there}} + test send-5.3 {ValidateName procedure} { + testsend prop root InterpRegistry "$id Bogus" + list [catch {send Bogus set a 44} msg] $msg + } {1 {target application died or uses a Tk version before 4.0}} + test send-5.4 {ValidateName procedure} { + tk appname test + testsend prop root InterpRegistry "$commId Bogus\n$commId test\n" + winfo interps + } {test} +} + +winfo interps +tk appname tktest +update +setupbg +set x [split [exec xhost] \n] +foreach i [lrange $x 1 end] { + exec xhost - $i +} +test send-6.1 {ServerSecure procedure} {nonPortable} { + set a 44 + list [dobg [list send [tk appname] set a 55]] $a +} {55 55} +test send-6.2 {ServerSecure procedure} {nonPortable} { + set a 22 + exec xhost [exec hostname] + list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg +} {0 22 {X server insecure (must use xauth-style authorization); command ignored}} +test send-6.3 {ServerSecure procedure} {nonPortable} { + set a abc + exec xhost - [exec hostname] + list [dobg [list send [tk appname] set a new]] $a +} {new new} +cleanupbg + +if $gotTestCmds { + test send-7.1 {Tk_SetAppName procedure} { + testsend prop root InterpRegistry "" + tk appname newName + list [tk appname oldName] [testsend prop root InterpRegistry] + } "oldName {$commId oldName\n}" + test send-7.2 {Tk_SetAppName procedure, name not in use} { + testsend prop root InterpRegistry "" + list [tk appname gorp] [testsend prop root InterpRegistry] + } "gorp {$commId gorp\n}" + test send-7.3 {Tk_SetAppName procedure, name in use by us} { + tk appname name1 + testsend prop root InterpRegistry "$commId name2\n" + list [tk appname name2] [testsend prop root InterpRegistry] + } "name2 {$commId name2\n}" + test send-7.4 {Tk_SetAppName procedure, name in use} { + tk appname name1 + testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n" + list [tk appname foo] [testsend prop root InterpRegistry] + } "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}" +} + +test send-8.1 {Tk_SendCmd procedure, options} { + setupbg + set app [dobg {tk appname}] + set a 66 + send -async $app [list send [tk appname] set a 77] + set result $a + after 200 set x 40 + tkwait variable x + cleanupbg + lappend result $a +} {66 77} +if [info exists env(TK_ALT_DISPLAY)] { + test send-8.2 {Tk_SendCmd procedure, options} { + setupbg -display $env(TK_ALT_DISPLAY) + tk appname xyzgorp + set a homeDisplay + set result [dobg " + toplevel .t -screen [winfo screen .] + wm geometry .t +0+0 + set a altDisplay + tk appname xyzgorp + list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\] + "] + cleanupbg + set result + } {altDisplay homeDisplay} +} +test send-8.3 {Tk_SendCmd procedure, options} { + list [catch {send -- -async foo bar baz} msg] $msg +} {1 {no application named "-async"}} +test send-8.4 {Tk_SendCmd procedure, options} { + list [catch {send -gorp foo bar baz} msg] $msg +} {1 {bad option "-gorp": must be -async, -displayof, or --}} +test send-8.5 {Tk_SendCmd procedure, options} { + list [catch {send -async foo} msg] $msg +} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} +test send-8.6 {Tk_SendCmd procedure, options} { + list [catch {send foo} msg] $msg +} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} +test send-8.7 {Tk_SendCmd procedure, local execution} { + set a initial + send [tk appname] {set a new} + set a +} {new} +test send-8.8 {Tk_SendCmd procedure, local execution} { + set a initial + send [tk appname] set a new + set a +} {new} +test send-8.9 {Tk_SendCmd procedure, local execution} { + set a initial + string tolower [list [catch {send [tk appname] open bad_file} msg] \ + $msg $errorInfo $errorCode] +} {1 {couldn't open "bad_file": no such file or directory} {couldn't open "bad_file": no such file or directory + while executing +"open bad_file" + invoked from within +"send [tk appname] open bad_file"} {posix enoent {no such file or directory}}} +test send-8.10 {Tk_SendCmd procedure, no such interpreter} { + list [catch {send bogus_name bogus_command} msg] $msg +} {1 {no application named "bogus_name"}} +if $gotTestCmds { + newApp "" t_s_1 Test + t_s_1 eval wm withdraw . + test send-8.11 {Tk_SendCmd procedure, local execution, different interp} { + set a us + send t_s_1 set a them + list $a [send t_s_1 set a] + } {us them} + test send-8.12 {Tk_SendCmd procedure, local execution, different interp} { + set a us + send t_s_1 {set a them} + list $a [send t_s_1 {set a}] + } {us them} + test send-8.13 {Tk_SendCmd procedure, local execution, different interp} { + set a us + send t_s_1 {set a them} + list $a [send t_s_1 {set a}] + } {us them} + test send-8.14 {Tk_SendCmd procedure, local interp killed by send} { + newApp "" t_s_2 Test + list [catch {send t_s_2 {destroy .; concat result}} msg] $msg + } {0 result} + interp delete t_s_2 + test send-8.15 {Tk_SendCmd procedure, local interp, error info} { + catch {error foo} + list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode + } {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory + while executing +"open bogus_file_name" + invoked from within +"send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}} + test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} { + testsend prop root InterpRegistry "10234 bogus\n" + set result [list [catch {send bogus bogus command} msg] $msg] + winfo interps + tk appname tktest + set result + } {1 {no application named "bogus"}} + interp delete t_s_1 +} +test send-8.17 {Tk_SendCmd procedure, deferring events} {nonPortable} { + # Non-portable because some window managers ignore "raise" + # requests so can't guarantee that new app's window won't + # obscure .f, thereby masking the Expose event. + + setupbg + set app [dobg {tk appname}] + raise . ; # Don't want new app obscuring .f + catch {destroy .f} + frame .f + place .f -x 0 -y 0 + bind .f <Expose> {set a exposed} + set a {no event yet} + set result "" + lappend result [send $app send [list [tk appname]] set a] + lappend result $a + update + cleanupbg + lappend result $a +} {{no event yet} {no event yet} exposed} +test send-8.18 {Tk_SendCmd procedure, error in remote app} { + setupbg + set app [dobg {tk appname}] + set result [string tolower [list [catch {send $app open bad_name} msg] \ + $msg $errorInfo $errorCode]] + cleanupbg + set result +} {1 {couldn't open "bad_name": no such file or directory} {couldn't open "bad_name": no such file or directory + while executing +"open bad_name" + invoked from within +"send $app open bad_name"} {posix enoent {no such file or directory}}} +test send-8.19 {Tk_SendCmd, using modal timeouts} { + setupbg + set app [dobg {tk appname}] + set x no + set result "" + after 0 {set x yes} + lappend result [send $app {concat x y z}] + lappend result $x + update + cleanupbg + lappend result $x +} {{x y z} no yes} + +tk appname tktest +catch {destroy .f} +frame .f +set id [string range [winfo id .f] 2 end] +if $gotTestCmds { + test send-9.1 {Tk_GetInterpNames procedure} { + testsend prop root InterpRegistry \ + "$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n" + list [winfo interps] [testsend prop root InterpRegistry] + } "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f +}" + test send-9.2 {Tk_GetInterpNames procedure} { + testsend prop root InterpRegistry \ + "$commId tktest\nfoobar\n$commId gorp\n" + list [winfo interps] [testsend prop root InterpRegistry] + } "tktest {$commId tktest\n}" + test send-9.3 {Tk_GetInterpNames procedure} { + testsend prop root InterpRegistry {} + list [winfo interps] [testsend prop root InterpRegistry] + } {{} {}} + + testsend prop root InterpRegistry "$commId tktest\n$id dummy\n" + test send-10.1 {SendEventProc procedure, bogus comm property} { + testsend prop comm Comm {abc def} + testsend prop comm Comm {} + update + } {} + test send-10.2 {SendEventProc procedure, simultaneous messages} { + testsend prop comm Comm \ + "c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n" + set a null + set b xyzzy + update + list $a $b + } {44 45} + test send-10.3 {SendEventProc procedure, simultaneous messages} { + testsend prop comm Comm \ + "c\n-n tktest\n-s set a newA\nr\n-s [testsend serial]\n-r 12345\nc\n-n tktest\n-s set b newB\n" + set a null + set b xyzzy + set x [send dummy bogus] + list $x $a $b + } {12345 newA newB} + test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} { + testsend prop comm Comm \ + "\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n" + set a null + update + set a + } {44} + test send-10.5 {SendEventProc procedure, extraneous command options} { + testsend prop comm Comm \ + "c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n" + set a null + update + set a + } {new} + test send-10.6 {SendEventProc procedure, unknown interpreter} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n unknown\n-r $id 44\n-s set a new\n" + set a null + update + list [testsend prop [winfo id .f] Comm] $a + } "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null" + test send-10.7 {SendEventProc procedure, error in script} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" + update + testsend prop [winfo id .f] Comm + } { +r +-s 62 +-r test error +-i Initial errorInfo + ("foreach" body line 1) + invoked from within +"foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}" +-e test code +-c 1 +} + test send-10.8 {SendEventProc procedure, exceptional return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-r $id 62\n-s break\n" + update + testsend prop [winfo id .f] Comm + } { +r +-s 62 +-r +-c 3 +} + test send-10.9 {SendEventProc procedure, empty return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-r $id 62\n-s concat\n" + update + testsend prop [winfo id .f] Comm + } { +r +-s 62 +-r +} + test send-10.10 {SendEventProc procedure, asynchronous calls} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" + update + testsend prop [winfo id .f] Comm + } {} + test send-10.11 {SendEventProc procedure, exceptional return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-s break\n" + update + testsend prop [winfo id .f] Comm + } {} + test send-10.12 {SendEventProc procedure, empty return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-s concat\n" + update + testsend prop [winfo id .f] Comm + } {} + test send-10.13 {SendEventProc procedure, return processing} { + testsend prop comm Comm \ + "r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n" + list [catch {send dummy foo} msg] $msg $errorInfo $errorCode + } {1 test3 {test2 + invoked from within +"send dummy foo"} test1} + test send-10.14 {SendEventProc procedure, extraneous return options} { + testsend prop comm Comm \ + "r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n" + list [catch {send dummy foo} msg] $msg + } {0 result} + test send-10.15 {SendEventProc procedure, serial number} { + testsend prop comm Comm \ + "r\n-r response\n" + list [catch {send dummy foo} msg] $msg + } {1 {target application died or uses a Tk version before 4.0}} + test send-10.16 {SendEventProc procedure, serial number} { + testsend prop comm Comm \ + "r\n-r response\n\n-s 0" + list [catch {send dummy foo} msg] $msg + } {1 {target application died or uses a Tk version before 4.0}} + test send-10.17 {SendEventProc procedure, errorCode and errorInfo} { + testsend prop comm Comm \ + "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n" + set errorCode oldErrorCode + set errorInfo oldErrorInfo + list [catch {send dummy foo} msg] $msg $errorInfo $errorCode + } {4 {} oldErrorInfo oldErrorCode} + test send-10.18 {SendEventProc procedure, send kills application} { + setupbg + dobg {tk appname t_s_3} + set x [list [catch {send t_s_3 destroy .} msg] $msg] + cleanupbg + set x + } {0 {}} + test send-10.19 {SendEventProc procedure, send exits} { + setupbg + dobg {tk appname t_s_3} + set x [list [catch {send t_s_3 exit} msg] $msg] + close $fd + set x + } {1 {target application died}} + + test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} { + testsend prop root InterpRegistry "0x21447 dummy\n" + list [catch {send dummy foo} msg] $msg + } {1 {no application named "dummy"}} + test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} { + testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n" + update + } {} +} + +winfo interps +tk appname tktest +catch {destroy .f} +frame .f +set id [string range [winfo id .f] 2 end] +if $gotTestCmds { + test send-12.1 {TimeoutProc procedure} { + testsend prop root InterpRegistry "$id dummy\n" + list [catch {send dummy foo} msg] $msg + } {1 {target application died or uses a Tk version before 4.0}} + testsend prop root InterpRegistry "" +} +test send-12.2 {TimeoutProc procedure} { + winfo interps + tk appname tktest + update + setupbg + puts $fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout} + set bgDone 0 + set bgData {} + flush $fd + tkwait variable bgDone + set app $bgData + after 200 + set result [list [catch {send $app foo} msg] $msg] + close $fd + set result +} {1 {target application died}} + +winfo interps +tk appname tktest +test send-13.1 {DeleteProc procedure} { + setupbg + set app [dobg {rename send {}; tk appname}] + set result [list [catch {send $app foo} msg] $msg [winfo interps]] + cleanupbg + set result +} {1 {no application named "tktest #2"} tktest} +test send-13.2 {DeleteProc procedure} { + winfo interps + tk appname tktest + rename send {} + set result {} + lappend result [winfo interps] [info commands send] + tk appname foo + lappend result [winfo interps] [info commands send] +} {{} {} foo send} + +if [info exists env(TK_ALT_DISPLAY)] { + test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} { + setupbg -display $env(TK_ALT_DISPLAY) + set result [dobg " + toplevel .t -screen [winfo screen .] + wm geometry .t +0+0 + tk appname xyzgorp1 + set x child + "] + toplevel .t -screen $env(TK_ALT_DISPLAY) + wm geometry .t +0+0 + tk appname xyzgorp2 + update + set y parent + set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}] + destroy .t + cleanupbg + set result + } {child parent} +} + +if $gotTestCmds { + testsend prop root InterpRegister $registry + tk appname tktest + test send-15.1 {UpdateCommWindow procedure} { + set x [list [testsend prop comm TK_APPLICATION]] + newApp "" t_s_1 Test + send t_s_1 wm withdraw . + newApp "" t_s_2 Test + send t_s_2 wm withdraw . + lappend x [testsend prop comm TK_APPLICATION] + interp delete t_s_1 + lappend x [testsend prop comm TK_APPLICATION] + interp delete t_s_2 + lappend x [testsend prop comm TK_APPLICATION] + } {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest} +} + +tk appname $name +if $gotTestCmds { + testsend prop root InterpRegistry $registry +} +if $gotTestCmds { + testdeleteapps +} +rename newApp {} diff --git a/tests/text.test b/tests/text.test new file mode 100644 index 0000000..3bd5a09 --- /dev/null +++ b/tests/text.test @@ -0,0 +1,1262 @@ +# This file is a Tcl script to test the code in the file tkText.c. +# This file is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) text.test 1.46 97/10/13 15:18:31 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +eval destroy [winfo child .] + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Text.borderWidth 2 +option add *Text.highlightThickness 2 +option add *Text.font {Courier -12} + +text .t -width 20 -height 10 +pack append . .t {top expand fill} +update +.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 . + +entry .t.e +.t.e insert end abcdefg +.t.e select from 0 + +.t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + +catch {destroy .t2} +text .t2 +set i 0 +foreach test { + {-background #ff00ff #ff00ff <gorp>} + {-bd 4 4 foo} + {-bg blue blue #xx} + {-borderwidth 7 7 ++} + {-cursor watch watch lousy} + {-exportselection no 0 maybe} + {-fg red red stupid} + {-font fixed fixed {}} + {-foreground #012 #012 bogus} + {-height 5 5 bad} + {-highlightbackground #123 #123 bogus} + {-highlightcolor #234 #234 bogus} + {-highlightthickness -2 0 bad} + {-insertbackground green green <bogus>} + {-insertborderwidth 45 45 bogus} + {-insertofftime 100 100 2.4} + {-insertontime 47 47 e1} + {-insertwidth 2.3 2 47d} + {-padx 3.4 3 2.4.} + {-pady 82 82 bogus} + {-relief raised raised bumpy} + {-selectbackground #ffff01234567 #ffff01234567 bogus} + {-selectborderwidth 21 21 3x} + {-selectforeground yellow yellow #12345} + {-spacing1 20 20 1.3x} + {-spacing1 -5 0 bogus} + {-spacing2 5 5 bogus} + {-spacing2 -1 0 bogus} + {-spacing3 20 20 bogus} + {-spacing3 -10 0 bogus} + {-state disabled disabled foo} + {-tabs {1i 2i 3i 4i} {1i 2i 3i 4i} bad_tabs} + {-width 73 73 2.4} + {-wrap word word bad_wrap} +} { + test text-1.[incr i] {text options} { + set result {} + lappend result [catch {.t2 configure [lindex $test 0] [lindex $test 3]}] + .t2 configure [lindex $test 0] [lindex $test 1] + lappend result [.t2 cget [lindex $test 0]] + } [list 1 [lindex $test 2]] +} +test text-1.[incr i] {text options} { + .t2 configure -takefocus "any old thing" + .t2 cget -takefocus +} {any old thing} +test text-1.[incr i] {text options} { + .t2 configure -xscrollcommand "x scroll command" + .t2 configure -xscrollcommand +} {-xscrollcommand xScrollCommand ScrollCommand {} {x scroll command}} +test text-1.[incr i] {text options} { + .t2 configure -yscrollcommand "test command" + .t2 configure -yscrollcommand +} {-yscrollcommand yScrollCommand ScrollCommand {} {test command}} +test text-1.[incr i] {text options} { + set result {} + foreach i [.t2 configure] { + lappend result [lindex $i 4] + } + set result +} {blue {} {} 7 watch 0 {} fixed #012 5 #123 #234 0 green 45 100 47 2 3 82 raised #ffff01234567 21 yellow 0 0 0 0 disabled {1i 2i 3i 4i} {any old thing} 73 word {x scroll command} {test command}} + +test text-2.1 {Tk_TextCmd procedure} { + list [catch {text} msg] $msg +} {1 {wrong # args: should be "text pathName ?options?"}} +test text-2.2 {Tk_TextCmd procedure} { + list [catch {text foobar} msg] $msg +} {1 {bad window path name "foobar"}} +test text-2.3 {Tk_TextCmd procedure} { + catch {destroy .t2} + list [catch {text .t2 -gorp nofun} msg] $msg [winfo exists .t2] +} {1 {unknown option "-gorp"} 0} +test text-2.4 {Tk_TextCmd procedure} { + catch {destroy .t2} + 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"} { + set relief flat +} else { + set relief raised +} +test text-2.5 {Tk_TextCmd procedure} { + catch {destroy .t2} + text .t2 + .t2 tag cget sel -relief +} $relief +test text-2.6 {Tk_TextCmd procedure} { + catch {destroy .t2} + list [text .t2] [winfo class .t2] +} {.t2 Text} + +test text-3.1 {TextWidgetCmd procedure, basics} { + list [catch {.t} msg] $msg +} {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, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} + +test text-4.1 {TextWidgetCmd procedure, "bbox" option} { + list [catch {.t bbox} msg] $msg +} {1 {wrong # args: should be ".t bbox index"}} +test text-4.2 {TextWidgetCmd procedure, "bbox" option} { + list [catch {.t bbox a b} msg] $msg +} {1 {wrong # args: should be ".t bbox index"}} +test text-4.3 {TextWidgetCmd procedure, "bbox" option} { + list [catch {.t bbox bad_mark} msg] $msg +} {1 {bad text index "bad_mark"}} + +test text-5.1 {TextWidgetCmd procedure, "cget" option} { + list [catch {.t cget} msg] $msg +} {1 {wrong # args: should be ".t cget option"}} +test text-5.2 {TextWidgetCmd procedure, "cget" option} { + list [catch {.t cget a b} msg] $msg +} {1 {wrong # args: should be ".t cget option"}} +test text-5.3 {TextWidgetCmd procedure, "cget" option} { + list [catch {.t cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test text-5.4 {TextWidgetCmd procedure, "cget" option} { + .t configure -bd 17 + .t cget -bd +} {17} +.t configure -bd [lindex [.t configure -bd] 3] + +test text-6.1 {TextWidgetCmd procedure, "compare" option} { + list [catch {.t compare a b} msg] $msg +} {1 {wrong # args: should be ".t compare index1 op index2"}} +test text-6.2 {TextWidgetCmd procedure, "compare" option} { + list [catch {.t compare a b c d} msg] $msg +} {1 {wrong # args: should be ".t compare index1 op index2"}} +test text-6.3 {TextWidgetCmd procedure, "compare" option} { + list [catch {.t compare @x == 1.0} msg] $msg +} {1 {bad text index "@x"}} +test text-6.4 {TextWidgetCmd procedure, "compare" option} { + list [catch {.t compare 1.0 < @y} msg] $msg +} {1 {bad text index "@y"}} +test text-6.5 {TextWidgetCmd procedure, "compare" option} { + list [.t compare 1.1 < 1.0] [.t compare 1.1 < 1.1] [.t compare 1.1 < 1.2] +} {0 0 1} +test text-6.6 {TextWidgetCmd procedure, "compare" option} { + list [.t compare 1.1 <= 1.0] [.t compare 1.1 <= 1.1] [.t compare 1.1 <= 1.2] +} {0 1 1} +test text-6.7 {TextWidgetCmd procedure, "compare" option} { + list [.t compare 1.1 == 1.0] [.t compare 1.1 == 1.1] [.t compare 1.1 == 1.2] +} {0 1 0} +test text-6.8 {TextWidgetCmd procedure, "compare" option} { + list [.t compare 1.1 >= 1.0] [.t compare 1.1 >= 1.1] [.t compare 1.1 >= 1.2] +} {1 1 0} +test text-6.9 {TextWidgetCmd procedure, "compare" option} { + list [.t compare 1.1 > 1.0] [.t compare 1.1 > 1.1] [.t compare 1.1 > 1.2] +} {1 0 0} +test text-6.10 {TextWidgetCmd procedure, "compare" option} { + list [.t com 1.1 != 1.0] [.t compare 1.1 != 1.1] [.t compare 1.1 != 1.2] +} {1 0 1} +test text-6.11 {TextWidgetCmd procedure, "compare" option} { + list [catch {.t compare 1.0 <x 1.2} msg] $msg +} {1 {bad comparison operator "<x": must be <, <=, ==, >=, >, or !=}} +test text-6.12 {TextWidgetCmd procedure, "compare" option} { + list [catch {.t compare 1.0 >> 1.2} msg] $msg +} {1 {bad comparison operator ">>": must be <, <=, ==, >=, >, or !=}} +test text-6.13 {TextWidgetCmd procedure, "compare" option} { + list [catch {.t compare 1.0 z 1.2} msg] $msg +} {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, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} + +# "configure" option is already covered above + +test text-7.1 {TextWidgetCmd procedure, "debug" option} { + list [catch {.t debug 0 1} msg] $msg +} {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, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} +test text-7.3 {TextWidgetCmd procedure, "debug" option} { + .t debug true + .t deb +} 1 +test text-7.4 {TextWidgetCmd procedure, "debug" option} { + .t debug false + .t debug +} 0 +.t debug + +test text-8.1 {TextWidgetCmd procedure, "delete" option} { + list [catch {.t delete} msg] $msg +} {1 {wrong # args: should be ".t delete index1 ?index2?"}} +test text-8.2 {TextWidgetCmd procedure, "delete" option} { + list [catch {.t delete a b c} msg] $msg +} {1 {wrong # args: should be ".t delete index1 ?index2?"}} +test text-8.3 {TextWidgetCmd procedure, "delete" option} { + list [catch {.t delete @x 2.2} msg] $msg +} {1 {bad text index "@x"}} +test text-8.4 {TextWidgetCmd procedure, "delete" option} { + list [catch {.t delete 2.3 @y} msg] $msg +} {1 {bad text index "@y"}} +test text-8.5 {TextWidgetCmd procedure, "delete" option} { + .t con -state disabled + .t delete 2.3 + .t g 2.0 2.end +} abcdefghijklm +.t con -state normal +test text-8.6 {TextWidgetCmd procedure, "delete" option} { + .t delete 2.3 + .t get 2.0 2.end +} abcefghijklm +test text-8.7 {TextWidgetCmd procedure, "delete" option} { + .t delete 2.1 2.3 + .t get 2.0 2.end +} aefghijklm + +test text-9.1 {TextWidgetCmd procedure, "get" option} { + list [catch {.t get} msg] $msg +} {1 {wrong # args: should be ".t get index1 ?index2?"}} +test text-9.2 {TextWidgetCmd procedure, "get" option} { + list [catch {.t get a b c} msg] $msg +} {1 {wrong # args: should be ".t get index1 ?index2?"}} +test text-9.3 {TextWidgetCmd procedure, "get" option} { + list [catch {.t get @q 3.1} msg] $msg +} {1 {bad text index "@q"}} +test text-9.4 {TextWidgetCmd procedure, "get" option} { + list [catch {.t get 3.1 @r} msg] $msg +} {1 {bad text index "@r"}} +test text-9.5 {TextWidgetCmd procedure, "get" option} { + .t get 5.7 5.3 +} {} +test text-9.6 {TextWidgetCmd procedure, "get" option} { + .t get 5.3 5.5 +} { G} +test text-9.7 {TextWidgetCmd procedure, "get" option} { + .t get 5.3 end +} { GIrl .#@? x_yz +!@#$% +Line 7 +} +.t mark set a 5.3 +.t mark set b 5.3 +.t mark set c 5.5 +test text-9.8 {TextWidgetCmd procedure, "get" option} { + .t get 5.2 5.7 +} {y GIr} +test text-9.9 {TextWidgetCmd procedure, "get" option} { + .t get 5.2 +} {y} +test text-9.10 {TextWidgetCmd procedure, "get" option} { + .t get 5.2 5.4 +} {y } + +test text-10.1 {TextWidgetCmd procedure, "index" option} { + list [catch {.t index} msg] $msg +} {1 {wrong # args: should be ".t index index"}} +test text-10.2 {TextWidgetCmd procedure, "index" option} { + list [catch {.t ind a b} msg] $msg +} {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, get, image, index, insert, mark, 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"}} +test text-10.5 {TextWidgetCmd procedure, "index" option} { + .t index 1.2 +} 1.2 + +test text-11.1 {TextWidgetCmd procedure, "insert" option} { + list [catch {.t insert 1.2} msg] $msg +} {1 {wrong # args: should be ".t insert index chars ?tagList chars tagList ...?"}} +test text-11.2 {TextWidgetCmd procedure, "insert" option} { + .t config -state disabled + .t insert 1.2 xyzzy + .t get 1.0 1.end +} {Line 1} +.t config -state normal +test text-11.3 {TextWidgetCmd procedure, "insert" option} { + .t insert 1.2 xyzzy + .t get 1.0 1.end +} {Lixyzzyne 1} +test text-11.4 {TextWidgetCmd procedure, "insert" option} { + .t delete 1.0 end + .t insert 1.0 "Sample text" x + .t tag ranges x +} {1.0 1.11} +test text-11.5 {TextWidgetCmd procedure, "insert" option} { + .t delete 1.0 end + .t insert 1.0 "Sample text" x + .t insert 1.2 "XYZ" y + list [.t tag ranges x] [.t tag ranges y] +} {{1.0 1.2 1.5 1.14} {1.2 1.5}} +test text-11.6 {TextWidgetCmd procedure, "insert" option} { + .t delete 1.0 end + .t insert 1.0 "Sample text" {x y z} + list [.t tag ranges x] [.t tag ranges y] [.t tag ranges z] +} {{1.0 1.11} {1.0 1.11} {1.0 1.11}} +test text-11.7 {TextWidgetCmd procedure, "insert" option} { + .t delete 1.0 end + .t insert 1.0 "Sample text" {x y z} + .t insert 1.3 "A" {a b z} + list [.t tag ranges a] [.t tag ranges b] [.t tag ranges x] [.t tag ranges y] [.t tag ranges z] +} {{1.3 1.4} {1.3 1.4} {1.0 1.3 1.4 1.12} {1.0 1.3 1.4 1.12} {1.0 1.12}} +test text-11.8 {TextWidgetCmd procedure, "insert" option} { + .t delete 1.0 end + list [catch {.t insert 1.0 "Sample text" "a \{b"} msg] $msg +} {1 {unmatched open brace in list}} +test text-11.9 {TextWidgetCmd procedure, "insert" option} { + .t delete 1.0 end + .t insert 1.0 "First" bold " " {} second "x y z" " third" + list [.t get 1.0 1.end] [.t tag ranges bold] [.t tag ranges x] \ + [.t tag ranges y] [.t tag ranges z] +} {{First second third} {1.0 1.5} {1.6 1.12} {1.6 1.12} {1.6 1.12}} +test text-11.10 {TextWidgetCmd procedure, "insert" option} { + .t delete 1.0 end + .t insert 1.0 "First" bold " second" silly + list [.t get 1.0 1.end] [.t tag ranges bold] [.t tag ranges silly] +} {{First second} {1.0 1.5} {1.5 1.12}} + +# Mark, scan, search, see, tag, window, xview, and yview actions are tested elsewhere. + +test text-12.1 {ConfigureText procedure} { + list [catch {.t2 configure -state foobar} msg] $msg +} {1 {bad state value "foobar": must be normal or disabled}} +test text-12.2 {ConfigureText procedure} { + .t2 configure -spacing1 -2 -spacing2 1 -spacing3 1 + list [.t2 cget -spacing1] [.t2 cget -spacing2] [.t2 cget -spacing3] +} {0 1 1} +test text-12.3 {ConfigureText procedure} { + .t2 configure -spacing1 1 -spacing2 -1 -spacing3 1 + list [.t2 cget -spacing1] [.t2 cget -spacing2] [.t2 cget -spacing3] +} {1 0 1} +test text-12.4 {ConfigureText procedure} { + .t2 configure -spacing1 1 -spacing2 1 -spacing3 -3 + list [.t2 cget -spacing1] [.t2 cget -spacing2] [.t2 cget -spacing3] +} {1 1 0} +test text-12.5 {ConfigureText procedure} { + set x [list [catch {.t2 configure -tabs {30 foo}} msg] $msg $errorInfo] + .t2 configure -tabs {10 20 30} + set x +} {1 {bad tab alignment "foo": must be left, right, center, or numeric} {bad tab alignment "foo": must be left, right, center, or numeric + (while processing -tabs option) + invoked from within +".t2 configure -tabs {30 foo}"}} +test text-12.6 {ConfigureText procedure} { + .t2 configure -tabs {10 20 30} + .t2 configure -tabs {} + .t2 cget -tabs +} {} +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}} +test text-12.8 {ConfigureText procedure} { + .t2 configure -selectborderwidth 17 -selectforeground #332211 \ + -selectbackground #abc + list [lindex [.t2 tag config sel -borderwidth] 4] \ + [lindex [.t2 tag config sel -foreground] 4] \ + [lindex [.t2 tag config sel -background] 4] +} {17 #332211 #abc} +test text-12.9 {ConfigureText procedure} { + .t2 configure -selectborderwidth {} + .t2 tag cget sel -borderwidth +} {} +test text-12.10 {ConfigureText procedure} { + list [catch {.t2 configure -selectborderwidth foo} msg] $msg +} {1 {bad screen distance "foo"}} +test text-12.11 {ConfigureText procedure} { + catch {destroy .t2} + .t.e select to 2 + text .t2 -exportselection 1 + selection get +} {ab} +test text-12.12 {ConfigureText procedure} { + catch {destroy .t2} + .t.e select to 2 + text .t2 -exportselection 0 + .t2 insert insert 1234657890 + .t2 tag add sel 1.0 1.4 + selection get +} {ab} +test text-12.13 {ConfigureText procedure} { + catch {destroy .t2} + .t.e select to 1 + text .t2 -exportselection 1 + .t2 insert insert 1234657890 + .t2 tag add sel 1.0 1.4 + selection get +} {1234} +test text-12.14 {ConfigureText procedure} { + catch {destroy .t2} + .t.e select to 1 + text .t2 -exportselection 0 + .t2 insert insert 1234657890 + .t2 tag add sel 1.0 1.4 + .t2 configure -exportselection 1 + selection get +} {1234} +test text-12.15 {ConfigureText procedure} { + catch {destroy .t2} + text .t2 -exportselection 1 + .t2 insert insert 1234657890 + .t2 tag add sel 1.0 1.4 + set result [selection get] + .t2 configure -exportselection 0 + lappend result [catch {selection get} msg] $msg +} {1234 1 {PRIMARY selection doesn't exist or form "STRING" not defined}} +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 + pack append .t2 .t2.t top + wm geometry .t2 +0+0 + update + wm geometry .t2 +} {150x140+0+0} +test text-12.17 {ConfigureText procedure} { + # This test was failing Windows because the title bar on .t2 + # 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 + text .t2.t -width 20 -height 10 -setgrid 1 + pack append .t2 .t2.t top + wm geometry .t2 +0+0 + update + wm geometry .t2 +} {20x10+0+0} +test text-12.18 {ConfigureText procedure} { + # This test was failing on Windows because the title bar on .t2 + # 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 + text .t2.t -width 20 -height 10 -setgrid 1 + pack append .t2 .t2.t top + wm geometry .t2 +0+0 + update + set result [wm geometry .t2] + wm geometry .t2 15x8 + update + lappend result [wm geometry .t2] + .t2.t configure -wrap word + update + lappend result [wm geometry .t2] +} {20x10+0+0 15x8+0+0 15x8+0+0} + +test text-13.1 {TextWorldChanged procedure, spacing options} fonts { + catch {destroy .t2} + text .t2 -width 20 -height 10 + set result [winfo reqheight .t2] + .t2 configure -spacing1 2 + lappend result [winfo reqheight .t2] + .t2 configure -spacing3 1 + lappend result [winfo reqheight .t2] + .t2 configure -spacing1 0 + lappend result [winfo reqheight .t2] +} {140 160 170 150} + +test text-14.1 {TextEventProc procedure} { + text .tx1 -bg #543210 + rename .tx1 .tx2 + set x {} + lappend x [winfo exists .tx1] + lappend x [.tx2 cget -bg] + destroy .tx1 + lappend x [info command .tx*] [winfo exists .tx1] [winfo exists .tx2] +} {1 #543210 {} 0 0} + +test text-15.1 {TextCmdDeletedProc procedure} { + text .tx1 + rename .tx1 {} + list [info command .tx*] [winfo exists .tx1] +} {{} 0} +test text-15.2 {TextCmdDeletedProc procedure, disabling -setgrid} fonts { + catch {destroy .top} + toplevel .top + wm geom .top +0+0 + text .top.t -setgrid 1 -width 20 -height 10 + pack .top.t + update + set x [wm geometry .top] + rename .top.t {} + update + lappend x [wm geometry .top] + destroy .top + set x +} {20x10+0+0 150x140+0+0} + +test text-16.1 {InsertChars procedure} { + catch {destroy .t2} + text .t2 + .t2 insert 2.0 abcd\n + .t2 get 1.0 end +} {abcd + +} +test text-16.2 {InsertChars procedure} { + catch {destroy .t2} + text .t2 + .t2 insert 1.0 abcd\n + .t2 insert end 123\n + .t2 get 1.0 end +} {abcd +123 + +} +test text-16.3 {InsertChars procedure} { + catch {destroy .t2} + text .t2 + .t2 insert 1.0 abcd\n + .t2 insert 10.0 123 + .t2 get 1.0 end +} {abcd +123 +} +test text-16.4 {InsertChars procedure, inserting on top visible line} { + catch {destroy .t2} + text .t2 -width 20 -height 4 -wrap word + pack .t2 + .t2 insert insert "Now is the time for all great men to come to the " + .t2 insert insert "aid of their party.\n" + .t2 insert insert "Now is the time for all great men.\n" + .t2 see end + update + .t2 insert 1.0 "Short\n" + .t2 index @0,0 +} {2.56} +test text-16.5 {InsertChars procedure, inserting on top visible line} { + catch {destroy .t2} + text .t2 -width 20 -height 4 -wrap word + pack .t2 + .t2 insert insert "Now is the time for all great men to come to the " + .t2 insert insert "aid of their party.\n" + .t2 insert insert "Now is the time for all great men.\n" + .t2 see end + update + .t2 insert 1.55 "Short\n" + .t2 index @0,0 +} {2.0} +test text-16.6 {InsertChars procedure, inserting on top visible line} { + catch {destroy .t2} + text .t2 -width 20 -height 4 -wrap word + pack .t2 + .t2 insert insert "Now is the time for all great men to come to the " + .t2 insert insert "aid of their party.\n" + .t2 insert insert "Now is the time for all great men.\n" + .t2 see end + update + .t2 insert 1.56 "Short\n" + .t2 index @0,0 +} {1.56} +test text-16.7 {InsertChars procedure, inserting on top visible line} { + catch {destroy .t2} + text .t2 -width 20 -height 4 -wrap word + pack .t2 + .t2 insert insert "Now is the time for all great men to come to the " + .t2 insert insert "aid of their party.\n" + .t2 insert insert "Now is the time for all great men.\n" + .t2 see end + update + .t2 insert 1.57 "Short\n" + .t2 index @0,0 +} {1.56} +catch {destroy .t2} + +proc setup {} { + .t delete 1.0 end + .t insert 1.0 "Line 1 +abcde +12345 +Line 4" +} + +.t delete 1.0 end +test text-17.1 {DeleteChars procedure} { + .t get 1.0 end +} { +} +test text-17.2 {DeleteChars procedure} { + list [catch {.t delete foobar} msg] $msg +} {1 {bad text index "foobar"}} +test text-17.3 {DeleteChars procedure} { + list [catch {.t delete 1.0 lousy} msg] $msg +} {1 {bad text index "lousy"}} +test text-17.4 {DeleteChars procedure} { + setup + .t delete 2.1 + .t get 1.0 end +} {Line 1 +acde +12345 +Line 4 +} +test text-17.5 {DeleteChars procedure} { + setup + .t delete 2.3 + .t get 1.0 end +} {Line 1 +abce +12345 +Line 4 +} +test text-17.6 {DeleteChars procedure} { + setup + .t delete 2.end + .t get 1.0 end +} {Line 1 +abcde12345 +Line 4 +} +test text-17.7 {DeleteChars procedure} { + setup + .t tag add sel 4.2 end + .t delete 4.2 end + list [.t tag ranges sel] [.t get 1.0 end] +} {{} {Line 1 +abcde +12345 +Li +}} +test text-17.8 {DeleteChars procedure} { + setup + .t tag add sel 1.0 end + .t delete 4.0 end + list [.t tag ranges sel] [.t get 1.0 end] +} {{1.0 3.5} {Line 1 +abcde +12345 +}} +test text-17.9 {DeleteChars procedure} { + setup + .t delete 2.2 2.2 + .t get 1.0 end +} {Line 1 +abcde +12345 +Line 4 +} +test text-17.10 {DeleteChars procedure} { + setup + .t delete 2.3 2.1 + .t get 1.0 end +} {Line 1 +abcde +12345 +Line 4 +} +test text-17.11 {DeleteChars procedure} { + catch {destroy .t2} + toplevel .t2 + text .t2.t -width 20 -height 5 + pack append .t2 .t2.t top + wm geometry .t2 +0+0 + .t2.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns" + update + .t2.t delete 1.0 3.0 + list [.t2.t index @0,0] [.t2.t get @0,0] +} {1.0 x} +test text-17.12 {DeleteChars procedure} { + catch {destroy .t2} + toplevel .t2 + text .t2.t -width 20 -height 5 + pack append .t2 .t2.t top + wm geometry .t2 +0+0 + .t2.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns" + .t2.t yview 3.0 + update + .t2.t delete 2.0 4.0 + list [.t2.t index @0,0] [.t2.t get @0,0] +} {2.0 y} +catch {destroy .t2} +toplevel .t2 +text .t2.t -width 1 -height 10 -wrap char +frame .t2.f -width 200 -height 20 -relief raised -bd 2 +pack .t2.f .t2.t -side left +wm geometry .t2 +0+0 +update +test text-17.13 {DeleteChars procedure, updates affecting topIndex} { + .t2.t delete 1.0 end + .t2.t insert end "abcde\n12345\nqrstuv" + .t2.t yview 2.1 + .t2.t delete 1.4 2.3 + .t2.t index @0,0 +} {1.2} +test text-17.14 {DeleteChars procedure, updates affecting topIndex} { + .t2.t delete 1.0 end + .t2.t insert end "abcde\n12345\nqrstuv" + .t2.t yview 2.1 + .t2.t delete 2.3 2.4 + .t2.t index @0,0 +} {2.0} +test text-17.15 {DeleteChars procedure, updates affecting topIndex} { + .t2.t delete 1.0 end + .t2.t insert end "abcde\n12345\nqrstuv" + .t2.t yview 1.3 + .t2.t delete 1.0 1.2 + .t2.t index @0,0 +} {1.1} +test text-17.16 {DeleteChars procedure, updates affecting topIndex} { + catch {destroy .t2} + toplevel .t2 + text .t2.t -width 6 -height 10 -wrap word + frame .t2.f -width 200 -height 20 -relief raised -bd 2 + pack .t2.f .t2.t -side left + wm geometry .t2 +0+0 + update + .t2.t insert end "abc def\n01 2345 678 9101112\nLine 3\nLine 4\nLine 5\n6\n7\n8\n" + .t2.t yview 2.4 + .t2.t delete 2.5 + set x [.t2.t index @0,0] + .t2.t delete 2.5 + list $x [.t2.t index @0,0] +} {2.3 2.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} { + .t insert end $i.0$i.1$i.2$i.3$i.4\n +} +test text-18.1 {TextFetchSelection procedure} { + .t tag add sel 1.3 3.4 + selection get +} {a.1a.2a.3a.4 +b.0b.1b.2b.3b.4 +c.0c} +test text-18.2 {TextFetchSelection procedure} { + .t tag add x 1.2 + .t tag add x 1.4 + .t tag add x 2.0 + .t tag add x 2.3 + .t tag remove sel 1.0 end + .t tag add sel 1.0 3.4 + selection get +} {a.0a.1a.2a.3a.4 +b.0b.1b.2b.3b.4 +c.0c} +test text-18.3 {TextFetchSelection procedure} { + .t tag remove sel 1.0 end + .t tag add sel 13.3 + selection get +} {m} +test text-18.4 {TextFetchSelection procedure} { + .t tag remove x 1.0 end + .t tag add sel 1.0 3.4 + .t tag remove sel 1.0 end + .t tag add sel 1.2 1.5 + .t tag add sel 2.4 3.1 + .t tag add sel 10.0 10.end + .t tag add sel 13.3 + selection get +} {0a..1b.2b.3b.4 +cj.0j.1j.2j.3j.4m} +set x "" +for {set i 1} {$i < 200} {incr i} { + append x "This is line $i, padded to just about 53 characters.\n" +} +test text-18.5 {TextFetchSelection procedure, long selections} { + .t delete 1.0 end + .t insert end $x + .t tag add sel 1.0 end + selection get +} $x\n + +test text-19.1 {TkTextLostSelection procedure} {unixOnly} { + catch {destroy .t2} + text .t2 + .t2 insert 1.0 "abc\ndef\nghijk\n1234" + .t2 tag add sel 1.2 3.3 + .t.e select to 1 + .t2 tag ranges sel +} {} +test text-19.2 {TkTextLostSelection procedure} {macOrPc} { + catch {destroy .t2} + text .t2 + .t2 insert 1.0 "abc\ndef\nghijk\n1234" + .t2 tag add sel 1.2 3.3 + .t.e select to 1 + .t2 tag ranges sel +} {1.2 3.3} +catch {destroy .t2} +test text-19.3 {TkTextLostSelection procedure} { + catch {destroy .t2} + text .t2 + .t2 insert 1.0 "abcdef\nghijk\n1234" + .t2 tag add sel 1.0 1.3 + set x [selection get] + selection clear + lappend x [catch {selection get} msg] $msg + .t2 tag add sel 1.0 1.3 + lappend x [selection get] +} {abc 1 {PRIMARY selection doesn't exist or form "STRING" not defined} abc} + +.t delete 1.0 end +.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 -forward, -backward, -exact, -regexp, -nocase, -count, or --}} +test text-20.2 {TextSearchCmd procedure, -backwards option} { + .t search -backwards xyz 1.4 +} {1.1} +test text-20.3 {TextSearchCmd procedure, -forwards option} { + .t search -forwards xyz 1.4 +} {1.5} +test text-20.4 {TextSearchCmd procedure, -exact option} { + .t search -f -exact x. 1.0 +} {1.9} +test text-20.5 {TextSearchCmd procedure, -regexp option} { + .t search -b -regexp x.z 1.4 +} {1.1} +test text-20.6 {TextSearchCmd procedure, -count option} { + set length unmodified + list [.t search -count length x. 1.4] $length +} {1.9 2} +test text-20.7 {TextSearchCmd procedure, -count option} { + list [catch {.t search -count} msg] $msg +} {1 {no value given for "-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 +} {2.13} +test text-20.10 {TextSearchCmd procedure, -- option} { + .t search -- -forward 1.0 +} {2.4} +test text-20.11 {TextSearchCmd procedure, argument parsing} { + list [catch {.t search abc} msg] $msg +} {1 {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?}} +test text-20.12 {TextSearchCmd procedure, argument parsing} { + list [catch {.t search abc d e f} msg] $msg +} {1 {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?}} +test text-20.13 {TextSearchCmd procedure, check index} { + list [catch {.t search abc gorp} msg] $msg +} {1 {bad text index "gorp"}} +test text-20.14 {TextSearchCmd procedure, startIndex == "end"} { + .t search non-existent end +} {} +test text-20.15 {TextSearchCmd procedure, startIndex == "end"} { + .t search non-existent end +} {} +test text-20.16 {TextSearchCmd procedure, bad stopIndex} { + list [catch {.t search abc 1.0 lousy} msg] $msg +} {1 {bad text index "lousy"}} +test text-20.17 {TextSearchCmd procedure, pattern case conversion} { + list [.t search -nocase BAR 1.1] [.t search BAR 1.1] +} {2.13 {}} +test text-20.18 {TextSearchCmd procedure, bad regular expression pattern} { + list [catch {.t search -regexp a( 1.0} msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} +test text-20.19 {TextSearchCmd procedure, skip dummy last line} { + .t search -backwards BaR end 1.0 +} {2.23} +test text-20.20 {TextSearchCmd procedure, skip dummy last line} { + .t search -backwards \n end 1.0 +} {3.9} +test text-20.21 {TextSearchCmd procedure, skip dummy last line} { + .t search \n end +} {1.15} +test text-20.22 {TextSearchCmd procedure, skip dummy last line} { + .t search -back \n 1.0 +} {3.9} +test text-20.23 {TextSearchCmd procedure, extract line contents} { + .t tag add foo 1.2 + .t tag add x 1.3 + .t mark set silly 1.2 + .t search xyz 3.6 +} {1.1} +test text-20.24 {TextSearchCmd procedure, stripping newlines} { + .t search the\n 1.0 +} {1.12} +test text-20.25 {TextSearchCmd procedure, stripping newlines} { + .t search -regexp the\n 1.0 +} {} +test text-20.26 {TextSearchCmd procedure, stripping newlines} { + .t search -regexp {the$} 1.0 +} {1.12} +test text-20.27 {TextSearchCmd procedure, stripping newlines} { + .t search -regexp \n 1.0 +} {} +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} +test text-20.29 {TextSearchCmd procedure, firstChar and lastChar} { + .t search -backwards xyz 1.6 +} {1.5} +test text-20.30 {TextSearchCmd procedure, firstChar and lastChar} { + .t search -backwards xyz 1.5 +} {1.1} +test text-20.31 {TextSearchCmd procedure, firstChar and lastChar} { + .t search xyz 1.5 +} {1.5} +test text-20.32 {TextSearchCmd procedure, firstChar and lastChar} { + .t search xyz 1.6 +} {3.0} +test text-20.33 {TextSearchCmd procedure, firstChar and lastChar} { + .t search {} 1.end +} {1.15} +test text-20.34 {TextSearchCmd procedure, firstChar and lastChar} { + .t search f 1.end +} {2.0} +test text-20.35 {TextSearchCmd procedure, firstChar and lastChar} { + .t search {} end +} {1.0} +catch {destroy .t2} +toplevel .t2 +wm geometry .t2 +0+0 +text .t2.t -width 30 -height 10 +pack .t2.t +.t2.t insert 1.0 "This is a line\nand this is another" +.t2.t insert end "\nand this is yet another" +frame .t2.f -width 20 -height 20 -bd 2 -relief raised +.t2.t window create 2.5 -window .t2.f +test text-20.36 {TextSearchCmd procedure, firstChar and lastChar} { + .t2.t search his 2.6 +} {2.6} +test text-20.37 {TextSearchCmd procedure, firstChar and lastChar} { + .t2.t search this 2.6 +} {3.4} +test text-20.38 {TextSearchCmd procedure, firstChar and lastChar} { + .t2.t search is 2.6 +} {2.7} +test text-20.39 {TextSearchCmd procedure, firstChar and lastChar} { + .t2.t search his 2.7 +} {3.5} +test text-20.40 {TextSearchCmd procedure, firstChar and lastChar} { + .t2.t search -backwards "his is another" 2.6 +} {2.6} +test text-20.41 {TextSearchCmd procedure, firstChar and lastChar} { + .t2.t search -backwards "his is" 2.6 +} {1.1} +destroy .t2 +test text-20.42 {TextSearchCmd procedure, firstChar and lastChar} { + .t search -backwards forw 2.5 +} {2.5} +test text-20.43 {TextSearchCmd procedure, firstChar and lastChar} { + .t search forw 2.5 +} {2.5} +test text-20.44 {TextSearchCmd procedure, firstChar and lastChar} { + catch {destroy .t2} + text .t2 + list [.t2 search a 1.0] [.t2 search -backward a 1.0] +} {{} {}} +test text-20.45 {TextSearchCmd procedure, regexp match length} { + set length unchanged + list [.t search -regexp -count length x(.)(.*)z 1.1] $length +} {1.1 7} +test text-20.46 {TextSearchCmd procedure, regexp match length} { + set length unchanged + list [.t search -regexp -backward -count length fo* 2.5] $length +} {2.0 3} +test text-20.47 {TextSearchCmd procedure, checking stopIndex} { + list [.t search bar 2.1 2.13] [.t search bar 2.1 2.14] \ + [.t search bar 2.12 2.14] [.t search bar 2.14 2.14] +} {{} 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] +} {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 + frame .t.f3 -width 20 -height 20 -relief raised -bd 2 + frame .t.f4 -width 20 -height 20 -relief raised -bd 2 + .t window create 2.10 -window .t.f3 + .t window create 2.8 -window .t.f2 + .t window create 2.8 -window .t.f1 + .t window create 2.1 -window .t.f4 + set result "" + lappend result [.t search -count x forward 1.0] $x + lappend result [.t search -count x wa 1.0] $x + .t delete 2.1 + .t delete 2.8 2.10 + .t delete 2.10 + set result +} {2.6 10 2.11 2} +test text-20.50 {TextSearchCmd procedure, error setting variable} { + catch {unset a} + set a 44 + list [catch {.t search -count a(2) xyz 1.0} msg] $msg +} {1 {can't set "a(2)": variable isn't array}} +test text-20.51 {TextSearchCmd procedure, wrap-around} { + .t search -backwards xyz 1.1 +} {3.5} +test text-20.52 {TextSearchCmd procedure, wrap-around} { + .t search -backwards xyz 1.1 1.0 +} {} +test text-20.53 {TextSearchCmd procedure, wrap-around} { + .t search xyz 3.6 +} {1.1} +test text-20.54 {TextSearchCmd procedure, wrap-around} { + .t search xyz 3.6 end +} {} +test text-20.55 {TextSearchCmd procedure, no match} { + .t search non_existent 3.5 +} {} +test text-20.56 {TextSearchCmd procedure, no match} { + .t search -regexp non_existent 3.5 +} {} +test text-20.57 {TextSearchCmd procedure, special cases} { + .t search -back x 1.1 +} {1.0} +test text-20.58 {TextSearchCmd procedure, special cases} { + .t search -back x 1.0 +} {3.8} +test text-20.59 {TextSearchCmd procedure, special cases} { + .t search \n {end-2c} +} {3.9} +test text-20.60 {TextSearchCmd procedure, special cases} { + .t search \n end +} {1.15} +test text-20.61 {TextSearchCmd procedure, special cases} { + .t search x 1.0 +} {1.0} +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. + + set p abcdefg1234567890 + set p $p$p$p$p$p$p$p$p + set p $p$p$p$p$p + .t search -nocase $p 1.0 +} {} + +eval destroy [winfo child .] +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}} +test text-21.2 {TkTextGetTabs procedure} { + list [catch {.t2 configure -tabs xyz} msg] $msg +} {1 {bad screen distance "xyz"}} +test text-21.3 {TkTextGetTabs procedure} { + .t2 configure -tabs {100 200} + update idletasks + list [lindex [.t2 bbox 1.2] 0] [lindex [.t2 bbox 1.4] 0] +} {100 200} +test text-21.4 {TkTextGetTabs procedure} { + .t2 configure -tabs {100 right 200 left 300 center 400 numeric} + update idletasks + list [expr [lindex [.t2 bbox 1.2] 0] + [lindex [.t2 bbox 1.2] 2]] \ + [lindex [.t2 bbox 1.4] 0] \ + [expr [lindex [.t2 bbox 1.6] 0] + [lindex [.t2 bbox 1.6] 2]/2] \ + [lindex [.t2 bbox 1.10] 0] +} {100 200 300 400} +test text-21.5 {TkTextGetTabs procedure} { + .t2 configure -tabs {105 r 205 l 305 c 405 n} + update idletasks + list [expr [lindex [.t2 bbox 1.2] 0] + [lindex [.t2 bbox 1.2] 2]] \ + [lindex [.t2 bbox 1.4] 0] \ + [expr [lindex [.t2 bbox 1.6] 0] + [lindex [.t2 bbox 1.6] 2]/2] \ + [lindex [.t2 bbox 1.10] 0] +} {105 205 305 405} +test text-21.6 {TkTextGetTabs procedure} { + list [catch {.t2 configure -tabs {100 left 200 lork}} msg] $msg +} {1 {bad tab alignment "lork": must be left, right, center, or numeric}} +test text-21.7 {TkTextGetTabs procedure} { + list [catch {.t2 configure -tabs {100 !44 200 lork}} msg] $msg +} {1 {bad screen distance "!44"}} + +eval destroy [winfo child .] +text .t +pack .t +.t insert 1.0 "One Line" +.t mark set insert 1.0 + +test text-22.1 {TextDumpCmd procedure, bad args} { + list [catch {.t dump} msg] $msg +} {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}} +test text-22.2 {TextDumpCmd procedure, bad args} { + list [catch {.t dump -all} msg] $msg +} {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}} +test text-22.3 {TextDumpCmd procedure, bad args} { + list [catch {.t dump -command} msg] $msg +} {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?}} +test text-22.5 {TextDumpCmd procedure, bad args} { + list [catch {.t dump bogus} msg] $msg +} {1 {bad text index "bogus"}} +test text-22.6 {TextDumpCmd procedure, one index} { + .t dump -text 1.2 +} {text e 1.2} +test text-22.7 {TextDumpCmd procedure, two indices} { + .t dump -text 1.0 1.end +} {text {One Line} 1.0} +test text-22.8 {TextDumpCmd procedure, "end" index} { + .t dump -text 1.end end +} {text { +} 1.8} +test text-22.9 {TextDumpCmd procedure, same indices} { + .t dump 1.5 1.5 +} {} +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 +} 1.0} +test text-22.12 {TextDumpCmd procedure, span multiple lines} { + .t dump -text 1.5 3.end +} {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 +.t mark set n 4.0 +.t mark set END end +test text-22.13 {TextDumpCmd procedure, tags only} { + .t dump -tag 2.1 2.8 +} {} +test text-22.14 {TextDumpCmd procedure, tags only} { + .t dump -tag 2.0 2.8 +} {tagon x 2.0} +test text-22.15 {TextDumpCmd procedure, tags only} { + .t dump -tag 1.0 4.end +} {tagon y 1.0 tagon x 2.0 tagoff x 2.8} +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} { + .t dump -mark 1.1 1.8 +} {} +test text-22.18 {TextDumpCmd procedure, marks only} { + .t dump -mark 2.0 2.8 +} {mark m 2.4} +test text-22.19 {TextDumpCmd procedure, marks only} { + .t dump -mark 1.1 4.end +} {mark m 2.4 mark n 4.0} +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} { + .t insert end "-\n" +} +.t window create 100.0 -create { } +test text-22.21 {TextDumpCmd procedure, windows only} { + .t dump -window 1.0 5.0 +} {window .hello 3.10} +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" +.t mark set insert 1.0 +.t mark set current 1.0 +.t tag add x 2.0 2.end +.t mark set m 2.4 +proc Append {varName key value index} { + upvar #0 $varName x + lappend x $key $index $value +} +test text-22.23 {TextDumpCmd procedure, command script} { + set x {} + .t dump -command {Append x} -all 1.0 end + set x +} {mark 1.0 current mark 1.0 insert text 1.0 {Line One +} tagon 2.0 x text 2.0 Line mark 2.4 m text 2.4 { Two} tagoff 2.8 x text 2.8 { +} text 3.0 {Line Three +} text 4.0 {Line Four +}} +test text-22.24 {TextDumpCmd procedure, command script} { + set x {} + .t dump -mark -command {Append x} 1.0 end + set x +} {mark 1.0 current mark 1.0 insert mark 2.4 m} +catch {unset x} + +set l [interp hidden] +eval destroy [winfo children .] + +test text-23.1 {text widget vs hidden commands} { + catch {destroy .t} + text .t + interp hide {} .t + destroy .t + list [winfo children .] [interp hidden] +} [list {} $l] + +eval destroy [winfo child .] +option clear diff --git a/tests/textBTree.test b/tests/textBTree.test new file mode 100644 index 0000000..0ca5eb2 --- /dev/null +++ b/tests/textBTree.test @@ -0,0 +1,897 @@ +# This file is a Tcl script to test out the B-tree facilities of +# Tk's text widget (the contents of the file "tkTextBTree.c". There are +# several file with additional tests for other features of text widgets. +# This file is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) textBTree.test 1.8 96/03/21 15:51:12 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +catch {destroy .t} +text .t +.t debug on + +test btree-1.1 {basic insertions} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3\n" +test btree-1.2 {basic insertions} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 1.3 XXX + .t get 1.0 1000000.0 +} "LinXXXe 1\nLine 2\nLine 3\n" +test btree-1.3 {basic insertions} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 3.0 YYY + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nYYYLine 3\n" +test btree-1.4 {basic insertions} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 2.1 X\nYY + .t get 1.0 1000000.0 +} "Line 1\nLX\nYYine 2\nLine 3\n" +test btree-1.5 {basic insertions} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 2.0 X\n\n\n + .t get 1.0 1000000.0 +} "Line 1\nX\n\n\nLine 2\nLine 3\n" +test btree-1.6 {basic insertions} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 2.6 X\n + .t get 1.0 1000000.0 +} "Line 1\nLine 2X\n\nLine 3\n" +test btree-1.7 {insertion before start of text} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 0.4 XXX + .t get 1.0 1000000.0 +} "XXXLine 1\nLine 2\nLine 3\n" +test btree-1.8 {insertion past end of text} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 100.0 ZZ + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3ZZ\n" +test btree-1.9 {insertion before start of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 2.-3 Q + .t get 1.0 1000000.0 +} "Line 1\nQLine 2\nLine 3\n" +test btree-1.10 {insertion past end of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 2.40 XYZZY + .t get 1.0 1000000.0 +} "Line 1\nLine 2XYZZY\nLine 3\n" +test btree-1.11 {insertion past end of last line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t insert 3.40 ABC + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3ABC\n" + +test btree-2.1 {basic deletions} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 1.0 1.3 + .t get 1.0 1000000.0 +} "e 1\nLine 2\nLine 3\n" +test btree-2.2 {basic deletions} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 2.2 + .t get 1.0 1000000.0 +} "Line 1\nLie 2\nLine 3\n" +test btree-2.3 {basic deletions} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 2.0 2.3 + .t get 1.0 1000000.0 +} "Line 1\ne 2\nLine 3\n" +test btree-2.4 {deleting whole lines} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 1.2 3.0 + .t get 1.0 1000000.0 +} "LiLine 3\n" +test btree-2.5 {deleting whole lines} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\n\n\nLine 5" + .t delete 1.0 5.2 + .t get 1.0 1000000.0 +} "ne 5\n" +test btree-2.6 {deleting before start of file} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 0.3 1.2 + .t get 1.0 1000000.0 +} "ne 1\nLine 2\nLine 3\n" +test btree-2.7 {deleting after end of file} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 10.3 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3\n" +test btree-2.8 {deleting before start of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 3.-1 3.3 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\ne 3\n" +test btree-2.9 {deleting before start of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 1.-1 1.0 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3\n" +test btree-2.10 {deleting after end of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 1.8 2.1 + .t get 1.0 1000000.0 +} "Line 1ine 2\nLine 3\n" +test btree-2.11 {deleting after end of last line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 3.8 4.1 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3\n" +test btree-2.12 {deleting before start of file} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 1.8 0.0 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3\n" +test btree-2.13 {deleting past end of file} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 1.8 4.0 + .t get 1.0 1000000.0 +} "Line 1\n" +test btree-2.14 {deleting with end before start of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 1.3 2.-3 + .t get 1.0 1000000.0 +} "LinLine 2\nLine 3\n" +test btree-2.15 {deleting past end of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 1.3 1.9 + .t get 1.0 1000000.0 +} "Lin\nLine 2\nLine 3\n" +test btree-2.16 {deleting past end of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 3.2 3.15 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLi\n" +test btree-2.17 {deleting past end of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 3.0 3.15 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\n\n" +test btree-2.18 {deleting past end of line} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 1.0 3.15 + .t get 1.0 1000000.0 +} "\n" +test btree-2.19 {deleting with negative range} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 3.2 2.4 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3\n" +test btree-2.20 {deleting with negative range} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 3.2 3.1 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3\n" +test btree-2.21 {deleting with negative range} { + .t delete 1.0 100000.0 + .t insert 1.0 "Line 1\nLine 2\nLine 3" + .t delete 3.2 3.2 + .t get 1.0 1000000.0 +} "Line 1\nLine 2\nLine 3\n" + +proc setup {} { + .t delete 1.0 100000.0 + .t tag delete x y + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 1.1 + .t tag add x 1.5 1.13 + .t tag add x 2.2 2.6 + .t tag add y 1.5 +} + +test btree-3.1 {inserting with tags} { + setup + .t insert 1.0 XXX + list [.t tag ranges x] [.t tag ranges y] +} {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}} +test btree-3.2 {inserting with tags} { + setup + .t insert 1.15 YYY + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}} +test btree-3.3 {inserting with tags} { + setup + .t insert 1.7 ZZZZ + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}} +test btree-3.4 {inserting with tags} { + setup + .t insert 1.7 \n\n + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}} +test btree-3.5 {inserting with tags} { + setup + .t insert 1.5 A\n + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}} +test btree-3.6 {inserting with tags} { + setup + .t insert 1.13 A\n + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}} + +test btree-4.1 {deleting with tags} { + setup + .t delete 1.6 1.9 + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} +test btree-4.2 {deleting with tags} { + setup + .t delete 1.1 2.3 + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.4} {}} +test btree-4.3 {deleting with tags} { + setup + .t delete 1.4 2.1 + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 1.5 1.9} {}} +test btree-4.4 {deleting with tags} { + setup + .t delete 1.14 2.1 + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}} +test btree-4.5 {deleting with tags} { + setup + .t delete 1.0 2.10 + list [.t tag ranges x] [.t tag ranges y] +} {{} {}} +test btree-4.6 {deleting with tags} { + setup + .t delete 1.0 1.5 + list [.t tag ranges x] [.t tag ranges y] +} {{1.0 1.8 2.2 2.6} {1.0 1.1}} +test btree-4.7 {deleting with tags} { + setup + .t delete 1.6 1.9 + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} +test btree-4.8 {deleting with tags} { + setup + .t delete 1.5 1.13 + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 2.2 2.6} {}} + +set bigText1 {} +for {set i 0} {$i < 10} {incr i} { + append bigText1 "Line $i\n" +} +set bigText2 {} +for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" +} +test btree-5.1 {very large inserts, with tags} { + setup + .t insert 1.0 $bigText1 + list [.t tag ranges x] [.t tag ranges y] +} {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}} +test btree-5.2 {very large inserts, with tags} { + setup + .t insert 1.2 $bigText2 + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 1.2 201.3 201.11 202.2 202.6} {201.3 201.4}} +test btree-5.3 {very large inserts, with tags} { + setup + for {set i 0} {$i < 200} {incr i} { + .t insert 1.8 "longer line $i\n" + } + list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] [.t get 198.0 198.100] +} {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199} {longer line 2}} + +test btree-6.1 {very large deletes, with tags} { + setup + .t insert 1.1 $bigText2 + .t delete 1.2 201.2 + list [.t tag ranges x] [.t tag ranges y] +} {{1.4 1.12 2.2 2.6} {1.4 1.5}} +test btree-6.2 {very large deletes, with tags} { + setup + .t insert 1.1 $bigText2 + for {set i 0} {$i < 200} {incr i} { + .t delete 1.2 2.2 + } + list [.t tag ranges x] [.t tag ranges y] +} {{1.4 1.12 2.2 2.6} {1.4 1.5}} +test btree-6.3 {very large deletes, with tags} { + setup + .t insert 1.1 $bigText2 + .t delete 2.3 10000.0 + .t get 1.0 1000.0 +} {TLine 0 +Lin +} +test btree-6.4 {very large deletes, with tags} { + setup + .t insert 1.1 $bigText2 + for {set i 0} {$i < 100} {incr i} { + .t delete 30.0 31.0 + } + list [.t tag ranges x] [.t tag ranges y] +} {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}} +test btree-6.5 {very large deletes, with tags} { + setup + .t insert 1.1 $bigText2 + for {set i 0} {$i < 100} {incr i} { + set j [expr $i+2] + set k [expr 1+2*$i] + .t tag add x $j.1 $j.3 + .t tag add y $k.1 $k.6 + } + .t delete 2.0 200.0 + list [.t tag ranges x] [.t tag ranges y] +} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} +test btree-6.6 {very large deletes, with tags} { + setup + .t insert 1.1 $bigText2 + for {set i 0} {$i < 100} {incr i} { + set j [expr $i+2] + set k [expr 1+2*$i] + .t tag add x $j.1 $j.3 + .t tag add y $k.1 $k.6 + } + for {set i 199} {$i >= 2} {incr i -1} { + .t delete $i.0 [expr $i+1].0 + } + list [.t tag ranges x] [.t tag ranges y] +} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} + +.t delete 1.0 end +.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" +set i 1 +foreach check { + {1.3 1.6 1.7 2.0 {1.3 1.6 1.7 2.0}} + {1.3 1.6 1.6 2.0 {1.3 2.0}} + {1.3 1.6 1.4 2.0 {1.3 2.0}} + {2.0 4.3 1.4 1.10 {1.4 1.10 2.0 4.3}} + {2.0 4.3 1.4 1.end {1.4 1.19 2.0 4.3}} + {2.0 4.3 1.4 2.0 {1.4 4.3}} + {2.0 4.3 1.4 3.0 {1.4 4.3}} + {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2 {1.1 4.2}} + {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2 {1.2 4.2}} + {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0 {1.1 4.0}} + {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0 {1.2 4.0}} +} { + test btree-7.$i {tag addition and removal} { + .t tag remove x 1.0 end + while {[llength $check] > 2} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x + } [lindex $check [expr [llength $check]-1]] + incr i +} + +test btree-8.1 {tag addition and removal, weird ranges} { + .t delete 1.0 100000.0 + .t tag delete x + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 0.0 1.3 + .t tag ranges x +} {1.0 1.3} +test btree-8.2 {tag addition and removal, weird ranges} { + .t delete 1.0 100000.0 + .t tag delete x + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 1.40 2.4 + .t tag ranges x +} {1.19 2.4} +test btree-8.3 {tag addition and removal, weird ranges} { + .t delete 1.0 100000.0 + .t tag delete x + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 4.40 4.41 + .t tag ranges x +} {} +test btree-8.4 {tag addition and removal, weird ranges} { + .t delete 1.0 100000.0 + .t tag delete x + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 5.1 5.2 + .t tag ranges x +} {} +test btree-8.5 {tag addition and removal, weird ranges} { + .t delete 1.0 100000.0 + .t tag delete x + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 1.1 9.0 + .t tag ranges x +} {1.1 5.0} +test btree-8.6 {tag addition and removal, weird ranges} { + .t delete 1.0 100000.0 + .t tag delete x + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 1.1 1.90 + .t tag ranges x +} {1.1 1.19} +test btree-8.7 {tag addition and removal, weird ranges} { + .t delete 1.0 100000.0 + .t tag delete x + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 1.1 4.90 + .t tag ranges x +} {1.1 4.17} +test btree-8.8 {tag addition and removal, weird ranges} { + .t delete 1.0 100000.0 + .t tag delete x + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 3.0 3.0 + .t tag ranges x +} {} + +test btree-9.1 {tag names} { + setup + .t tag names +} {sel x y} +test btree-9.2 {tag names} { + setup + .t tag add tag1 1.8 + .t tag add tag2 1.8 + .t tag add tag3 1.7 1.9 + .t tag names 1.8 +} {x tag1 tag2 tag3} +test btree-9.3 {lots of tag names} { + setup + .t insert 1.2 $bigText2 + foreach i {tag1 foo ThisOne {x space} q r s t} { + .t tag add $i 150.2 + } + foreach i {u tagA tagB tagC and more {$} \{} { + .t tag add $i 150.1 150.3 + } + .t tag names 150.2 +} {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{} +test btree-9.4 {lots of tag names} { + setup + .t insert 1.2 $bigText2 + .t tag delete tag1 foo ThisOne more {x space} q r s t u + .t tag delete tagA tagB tagC and {$} \{ more + foreach i {tag1 foo ThisOne more {x space} q r s t} { + .t tag add $i 150.2 + } + foreach i {foo ThisOne u tagA tagB tagC and more {$} \{} { + .t tag add $i 150.4 + } + .t tag delete tag1 more q r tagA + .t tag names 150.2 +} {foo ThisOne {x space} s t} + +proc msetup {} { + .t delete 1.0 100000.0 + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t mark set m1 1.2 + .t mark set l1 1.2 + .t mark gravity l1 left + .t mark set next 1.6 + .t mark set x 1.6 + .t mark set m2 2.0 + .t mark set m3 2.100 + .t tag add x 1.3 1.8 +} +test btree-10.1 {basic mark facilities} { + msetup + list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3] +} {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11} +test btree-10.2 {basic mark facilities} { + msetup + .t mark unset m2 + lsort [.t mark names] +} {current insert l1 m1 m3 next x} +test btree-10.3 {basic mark facilities} { + msetup + .t mark set m2 1.8 + list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3] +} {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11} + +test btree-11.1 {marks and inserts} { + msetup + .t insert 1.1 abcde + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.7 1.7 1.11 1.11 2.0 2.11} +test btree-11.2 {marks and inserts} { + msetup + .t insert 1.2 abcde + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.7 1.11 1.11 2.0 2.11} +test btree-11.3 {marks and inserts} { + msetup + .t insert 1.3 abcde + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.2 1.11 1.11 2.0 2.11} +test btree-11.4 {marks and inserts} { + msetup + .t insert 1.1 ab\n\ncde + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {3.4 3.4 3.8 3.8 4.0 4.11} +test btree-11.5 {marks and inserts} { + msetup + .t insert 1.4 ab\n\ncde + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.2 3.5 3.5 4.0 4.11} +test btree-11.6 {marks and inserts} { + msetup + .t insert 1.7 ab\n\ncde + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.2 1.6 1.6 4.0 4.11} + +test btree-12.1 {marks and deletes} { + msetup + .t delete 1.3 1.5 + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.2 1.4 1.4 2.0 2.11} +test btree-12.2 {marks and deletes} { + msetup + .t delete 1.3 1.8 + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.2 1.3 1.3 2.0 2.11} +test btree-12.3 {marks and deletes} { + msetup + .t delete 1.2 1.8 + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.2 1.2 1.2 2.0 2.11} +test btree-12.4 {marks and deletes} { + msetup + .t delete 1.1 1.8 + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.1 1.1 1.1 1.1 2.0 2.11} +test btree-12.5 {marks and deletes} { + msetup + .t delete 1.5 3.1 + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.2 1.5 1.5 1.5 1.5} +test btree-12.6 {marks and deletes} { + msetup + .t mark set m2 4.5 + .t delete 1.5 4.1 + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.2 1.5 1.5 1.9 1.5} +test btree-12.7 {marks and deletes} { + msetup + .t mark set m2 4.5 + .t mark set m3 4.5 + .t mark set m1 4.7 + .t delete 1.5 4.1 + list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] +} {1.2 1.11 1.5 1.5 1.9 1.9} + +destroy .t +text .t +test btree-13.1 {tag searching} { + .t delete 1.0 100000.0 + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag next x 2.2 2.1 +} {} +test btree-13.2 {tag searching} { + .t delete 1.0 100000.0 + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 2.2 2.4 + .t tag next x 2.2 2.3 +} {2.2 2.4} +test btree-13.3 {tag searching} { + .t delete 1.0 100000.0 + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 2.2 2.4 + .t tag next x 2.3 2.6 +} {} +test btree-13.4 {tag searching} { + .t delete 1.0 100000.0 + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 2.5 2.8 + .t tag next x 2.1 2.6 +} {2.5 2.8} +test btree-13.5 {tag searching} { + .t delete 1.0 100000.0 + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 2.5 2.8 + .t tag next x 2.1 2.5 +} {} +test btree-13.6 {tag searching} { + .t delete 1.0 100000.0 + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 2.1 2.4 + .t tag next x 2.5 2.8 +} {} +test btree-13.7 {tag searching} { + .t delete 1.0 100000.0 + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 2.5 2.8 + .t tag next x 2.1 2.4 +} {} +test btree-13.8 {tag searching} { + setup + .t insert 1.2 $bigText2 + .t tag add x 190.3 191.2 + .t tag next x 3.5 +} {190.3 191.2} + +test btree-14.1 {check tag presence} { + setup + .t insert 1.2 $bigText2 + .t tag add x 3.5 3.7 + .t tag add y 133.9 141.5 + .t tag add z 1.5 180.2 + .t tag add q 141.4 142.3 + .t tag add x 130.2 145.1 + .t tag add a 141.0 + .t tag add b 4.3 + .t tag add b 7.5 + .t tag add b 140.3 + for {set i 120} {$i < 160} {incr i} { + .t tag add c $i.4 + } + foreach i {a1 a2 a3 a4 a5 a6 a7 a8 a9 10 a11 a12 a13} { + .t tag add $i 122.2 + } + .t tag add x 141.3 + .t tag names 141.1 +} {x y z} + +test btree-15.1 {rebalance with empty node} { + catch {destroy .t} + text .t + .t debug 1 + .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23" + .t delete 6.0 12.0 + .t get 1.0 end +} "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n" + +proc setupBig {} { + .t delete 1.0 end + .t tag delete x y + .t tag configure x -foreground blue + .t tag configure y -underline true + # Create a Btree with 2002 lines (2000 + already existing + phantom at end) + # This generates a level 3 node with 9 children + # Most level 2 nodes cover 216 lines and have 6 children, except the last + # level 2 node covers 274 lines and has 7 children. + # Most level 1 nodes cover 36 lines and have 6 children, except the + # rightmost node has 58 lines and 9 children. + # Level 2: 2002 = 8*216 + 274 + # Level 1: 2002 = 54*36 + 58 + # Level 0: 2002 = 332*6 + 10 + for {set i 0} {$i < 2000} {incr i} { + append x "Line $i abcd efgh ijkl\n" + } + .t insert insert $x + .t debug 1 +} + +test btree-16.1 {add tag does not push root above level 0} { + catch {destroy .t} + text .t + setupBig + .t tag add x 1.1 1.10 + .t tag add x 5.1 5.10 + .t tag ranges x +} {1.1 1.10 5.1 5.10} +test btree-16.2 {add tag pushes root up to level 1 node} { + catch {destroy .t} + text .t + .t debug 1 + setupBig + .t tag add x 1.1 1.10 + .t tag add x 8.1 8.10 + .t tag ranges x +} {1.1 1.10 8.1 8.10} +test btree-16.3 {add tag pushes root up to level 2 node} { + .t tag remove x 1.0 end + .t tag add x 8.1 9.10 + .t tag add x 180.1 180.end + .t tag ranges x +} {8.1 9.10 180.1 180.23} +test btree-16.4 {add tag pushes root up to level 3 node} { + .t tag remove x 1.0 end + .t tag add y 1.1 2000.0 + .t tag add x 1.1 8.10 + .t tag add x 180.end 217.0 + list [.t tag ranges x] [.t tag ranges y] +} {{1.1 8.10 180.23 217.0} {1.1 2000.0}} +test btree-16.5 {add tag doesn't push root up} { + .t tag remove x 1.0 end + .t tag add x 1.1 8.10 + .t tag add x 2000.0 2000.3 + .t tag add x 180.end 217.0 + .t tag ranges x +} {1.1 8.10 180.23 217.0 2000.0 2000.3} +test btree-16.6 {two node splits at once pushes root up} { + .t delete 1.0 end + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i\n" + } + .t tag add x 8.0 8.end + .t tag add y 9.0 end + set x {} + for {} {$i < 50} {incr i} { + append x "Line $i\n" + } + .t insert end $x y + list [.t tag ranges x] [.t tag ranges y] +} {{8.0 8.6} {9.0 51.0}} +# The following find bugs in the SearchStart procedures +test btree-16.7 {Partial tag remove from before first range} { + .t tag remove x 1.0 end + .t tag add x 2.0 2.6 + .t tag remove x 1.0 2.0 + .t tag ranges x +} {2.0 2.6} +test btree-16.8 {Partial tag remove from before first range} { + .t tag remove x 1.0 end + .t tag add x 2.0 2.6 + .t tag remove x 1.0 2.1 + .t tag ranges x +} {2.1 2.6} +test btree-16.9 {Partial tag remove from before first range} { + .t tag remove x 1.0 end + .t tag add x 2.0 2.6 + .t tag remove x 1.0 2.3 + .t tag ranges x +} {2.3 2.6} +test btree-16.10 {Partial tag remove from before first range} { + .t tag remove x 1.0 end + .t tag add x 1.0 2.6 + .t tag remove x 1.0 2.5 + .t tag ranges x +} {2.5 2.6} +test btree-16.11 {StartSearchBack boundary case} { + .t tag remove x 1.0 end + .t tag add x 1.3 1.4 + .t tag prevr x 2.0 1.4 +} {} +test btree-16.12 {StartSearchBack boundary case} { + .t tag remove x 1.0 end + .t tag add x 1.3 1.4 + .t tag prevr x 2.0 1.3 +} {1.3 1.4} +test btree-16.13 {StartSearchBack boundary case} { + .t tag remove x 1.0 end + .t tag add x 1.0 1.4 + .t tag prevr x 1.3 +} {1.0 1.4} + + +test btree-17.1 {remove tag does not push root down} { + catch {destroy .t} + text .t + .t debug 0 + setupBig + .t tag add x 1.1 5.10 + .t tag remove x 3.1 5.end + .t tag ranges x +} {1.1 3.1} +test btree-17.2 {remove tag pushes root from level 1 to level 0} { + .t tag remove x 1.0 end + .t tag add x 1.1 8.10 + .t tag remove x 3.1 end + .t tag ranges x +} {1.1 3.1} +test btree-17.3 {remove tag pushes root from level 2 to level 1} { + .t tag remove x 1.0 end + .t tag add x 1.1 180.10 + .t tag remove x 35.1 end + .t tag ranges x +} {1.1 35.1} +test btree-17.4 {remove tag doesn't change level 2} { + .t tag remove x 1.0 end + .t tag add x 1.1 180.10 + .t tag remove x 35.1 180.0 + .t tag ranges x +} {1.1 35.1 180.0 180.10} +test btree-17.5 {remove tag pushes root from level 3 to level 0} { + .t tag remove x 1.0 end + .t tag add x 1.1 1.10 + .t tag add x 2000.1 2000.10 + .t tag remove x 1.0 2000.0 + .t tag ranges x +} {2000.1 2000.10} +test btree-17.6 {text deletion pushes root from level 3 to level 0} { + .t tag remove x 1.0 end + .t tag add x 1.1 1.10 + .t tag add x 2000.1 2000.10 + .t delete 1.0 "1000.0 lineend +1 char" + .t tag ranges x +} {1000.1 1000.10} + +catch {destroy .t} +text .t +test btree-18.1 {tag search back, no tag} { + .t insert 1.0 "Line 1 abcd efgh ijkl\n" + .t tag prev x 1.1 1.1 +} {} +test btree-18.2 {tag search back, start at existing range} { + .t tag remove x 1.0 end + .t tag add x 1.1 1.4 + .t tag add x 1.8 1.11 + .t tag add x 1.16 + .t tag prev x 1.1 +} {} +test btree-18.3 {tag search back, end at existing range} { + .t tag remove x 1.0 end + .t tag add x 1.1 1.4 + .t tag add x 1.8 1.11 + .t tag add x 1.16 + .t tag prev x 1.3 1.1 +} {1.1 1.4} +test btree-18.4 {tag search back, start within range} { + .t tag remove x 1.0 end + .t tag add x 1.1 1.4 + .t tag add x 1.8 1.11 + .t tag add x 1.16 + .t tag prev x 1.10 1.0 +} {1.8 1.11} +test btree-18.5 {tag search back, start at end of range} { + .t tag remove x 1.0 end + .t tag add x 1.1 1.4 + .t tag add x 1.8 1.11 + .t tag add x 1.16 + list [.t tag prev x 1.4 1.0] [.t tag prev x 1.11 1.0] +} {{1.1 1.4} {1.8 1.11}} +test btree-18.6 {tag search back, start beyond range, same level 0 node} { + .t tag remove x 1.0 end + .t tag add x 1.1 1.4 + .t tag add x 1.8 1.11 + .t tag add x 1.16 + .t tag prev x 3.0 +} {1.16 1.17} +test btree-18.7 {tag search back, outside any range} { + .t tag remove x 1.0 end + .t tag add x 1.1 1.4 + .t tag add x 1.16 + .t tag prev x 1.8 1.5 +} {} +test btree-18.8 {tag search back, start at start of node boundary} { + setupBig + .t tag remove x 1.0 end + .t tag add x 2.5 2.8 + .t tag prev x 19.0 +} {2.5 2.8} +test btree-18.9 {tag search back, large complex btree spans} { + .t tag remove x 1.0 end + .t tag add x 1.3 1.end + .t tag add x 200.0 220.0 + .t tag add x 500.0 520.0 + list [.t tag prev x end] [.t tag prev x 433.0] +} {{500.0 520.0} {200.0 220.0}} + + +destroy .t diff --git a/tests/textDisp.test b/tests/textDisp.test new file mode 100644 index 0000000..c14f785 --- /dev/null +++ b/tests/textDisp.test @@ -0,0 +1,2868 @@ +# This file is a Tcl script to test the code in the file tkTextDisp.c. +# This file is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) textDisp.test 1.55 97/07/24 15:15:43 + +if {[string compare test [info procs test]] == 1} { + source defs + if {$testConfig(fonts) == 0} { + puts "skipping font-sensitive tests" + } +} + +# The procedure below is used as the scrolling command for the text; +# it just saves the scrolling information in a variable "scrollInfo". + +proc scroll args { + global scrollInfo + set scrollInfo $args +} + +# The procedure below is used to generate errors during scrolling commands. + +proc scrollError args { + error "scrolling error" +} + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Text.borderWidth 2 +option add *Text.highlightThickness 2 + +# The frame .f is needed to make sure that the overall window is always +# fairly wide, even if the text window is very narrow. This is needed +# because some window managers don't allow the overall width of a window +# to get very narrow. + +foreach i [winfo child .] { + destroy $i +} +frame .f -width 100 -height 20 +pack append . .f left + +if {$tcl_platform(platform) == "windows"} { + set fixedFont {Courier -14} +} else { + set fixedFont {Courier -12} +} +set fixedHeight [font metrics $fixedFont -linespace] +set fixedWidth [font measure $fixedFont m] + +set varFont {Times -14} +set bigFont {Helvetica -24} +text .t -font $fixedFont -width 20 -height 10 -yscrollcommand scroll +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 +} +test textDisp-1.1 {GetStyle procedure, priorities and tab stops} { + .t delete 1.0 end + .t insert 1.0 "x\ty" + .t tag delete x y z + .t tag configure x -tabs {50} + .t tag configure y -foreground black + .t tag configure z -tabs {70} + .t tag add x 1.0 1.end + .t tag add y 1.0 1.end + .t tag add z 1.0 1.end + update idletasks + set x [lindex [.t bbox 1.2] 0] + .t tag configure z -tabs {} + lappend x [lindex [.t bbox 1.2] 0] + .t tag configure z -tabs {30} + .t tag raise x + update idletasks + lappend x [lindex [.t bbox 1.2] 0] +} {75 55 55} +.t tag delete x y z +test textDisp-1.2 {GetStyle procedure, wrapmode} {fonts} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "abcd\nefg hijkl mnop qrstuv wxyz" + .t tag configure x -wrap word + .t tag configure y -wrap none + .t tag raise y + update + set result [list [.t bbox 2.20]] + .t tag add x 2.0 2.1 + 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} {}} +.t tag delete x y + +test textDisp-2.1 {LayoutDLine, basics} { + .t configure -wrap char + .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] +} [list [list [expr 5 + $fixedWidth * 19] 5 $fixedWidth $fixedHeight] [list 5 [expr 5 + $fixedHeight] $fixedWidth $fixedHeight]] +test textDisp-2.2 {LayoutDLine, basics} {fonts} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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}} +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} { + wm geom . [expr $width+1]x$height + update + .t configure -wrap char + .t delete 1.0 end + .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}} +wm geom . {} +update +test textDisp-2.9 {LayoutDLine, marks and tags} {fonts} { + .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} { + .t configure -wrap word + .t delete 1.0 end + .t insert 1.0 "This is a very_very_long_word_that_wraps." + .t tag add foo 1.13 + .t tag add foo 1.15 + .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} { + .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} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "\na\nbb\nccc\ndddd" + .t tag configure x -justify center + .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} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "\na\nbb\nccc\ndddd" + .t tag configure x -justify right + .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} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "\na\nbb\nccc\ndddd" + .t tag configure x -justify center + .t tag add x 2.0 3.1 + .t tag configure y -justify right + .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} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "\na\nbb\nccc\ndddd" + .t tag configure x -justify center + .t tag add x 2.0 3.1 + .t tag configure y -justify right + .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} { + .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.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} { + .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} { + .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" + .t insert end "Then\nmore lines\nThat are shorter" + .t tag configure x -justify center + .t tag configure y -justify right + .t tag add x 2.0 + .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}} +.t tag delete x +.t tag delete y +test textDisp-2.19 {LayoutDLine, margins} {fonts} { + .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} { + .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 10 -rmargin 3 + .t tag configure y -lmargin1 15 -lmargin2 5 -rmargin 0 + .t tag raise y + .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} { + .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}} +.t tag delete x +.t tag delete y +test textDisp-2.22 {LayoutDLine, spacing options} {fonts} { + .t configure -wrap word + .t delete 1.0 end + .t tag delete x y + .t insert end "Short line\nLine 2 is long enough " + .t insert end "to wrap around a couple of times" + .t insert end "\nLine 3\nLine 4" + set i [.t dlineinfo 1.0] + set b1 [expr [lindex $i 1] + [lindex $i 4]] + set i [.t dlineinfo 2.0] + set b2 [expr [lindex $i 1] + [lindex $i 4]] + set i [.t dlineinfo 2.end] + set b3 [expr [lindex $i 1] + [lindex $i 4]] + set i [.t dlineinfo 3.0] + set b4 [expr [lindex $i 1] + [lindex $i 4]] + .t configure -spacing1 2 -spacing2 1 -spacing3 3 + set i [.t dlineinfo 1.0] + set b1 [expr [lindex $i 1] + [lindex $i 4] - $b1] + set i [.t dlineinfo 2.0] + set b2 [expr [lindex $i 1] + [lindex $i 4] - $b2] + set i [.t dlineinfo 2.end] + set b3 [expr [lindex $i 1] + [lindex $i 4] - $b3] + 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} +.t configure -spacing1 0 -spacing2 0 -spacing3 0 +test textDisp-2.23 {LayoutDLine, spacing options} {fonts} { + .t configure -wrap word + .t delete 1.0 end + .t tag delete x y + .t insert end "Short line\nLine 2 is long enough " + .t insert end "to wrap around a couple of times" + .t insert end "\nLine 3\nLine 4" + set i [.t dlineinfo 1.0] + set b1 [expr [lindex $i 1] + [lindex $i 4]] + set i [.t dlineinfo 2.0] + set b2 [expr [lindex $i 1] + [lindex $i 4]] + set i [.t dlineinfo 2.end] + set b3 [expr [lindex $i 1] + [lindex $i 4]] + set i [.t dlineinfo 3.0] + set b4 [expr [lindex $i 1] + [lindex $i 4]] + .t configure -spacing1 4 -spacing2 4 -spacing3 4 + .t tag configure x -spacing1 1 -spacing2 2 -spacing3 3 + .t tag add x 1.0 end + .t tag configure y -spacing1 0 -spacing2 3 + .t tag add y 2.19 end + .t tag raise y + set i [.t dlineinfo 1.0] + set b1 [expr [lindex $i 1] + [lindex $i 4] - $b1] + set i [.t dlineinfo 2.0] + set b2 [expr [lindex $i 1] + [lindex $i 4] - $b2] + set i [.t dlineinfo 2.end] + set b3 [expr [lindex $i 1] + [lindex $i 4] - $b3] + 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} +.t configure -spacing1 0 -spacing2 0 -spacing3 0 +test textDisp-2.24 {LayoutDLine, tabs, saving from first chunk} {fonts} { + .t delete 1.0 end + .t tag delete x y + .t tag configure x -tabs 70 + .t tag configure y -tabs 80 + .t insert 1.0 "ab\tcde" + .t tag add x 1.0 end + .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} { + .t delete 1.0 end + .t tag delete x + .t tag configure x -tabs {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} { + .t delete 1.0 end + .t tag delete x + .t tag configure x -tabs {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} { + .t delete 1.0 end + .t tag delete x + .t tag configure x -tabs {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} { + .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} { + .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} { + .t delete 1.0 end + .t insert 1.0 "a\tx\tabc" + .t bbox 1.4 +} {117 5 7 13} + +test textDisp-3.1 {different character sizes} {fonts} { + .t configure -wrap word + .t delete 1.0 end + .t insert end "Some sample text, including both large\n" + .t insert end "characters and\nsmall\n" + .t insert end "abc\nd\ne\nfghij" + .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}} + +.t configure -wrap char +test textDisp-4.1 {UpdateDisplayInfo, basic} {fonts} { + .t delete 1.0 end + .t insert end "Line 1\nLine 2\nLine 3\n" + update + .t delete 2.0 2.end + .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} { + .t delete 1.0 end + .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" + update + .t mark set x 2.21 + .t delete 2.2 + .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} { + .t delete 1.0 end + .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" + update + .t mark set x 2.21 + .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}} +.t mark unset x +test textDisp-4.4 {UpdateDisplayInfo, wrap-mode "none"} {fonts} { + .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} { + wm geom . 103x$height + update + .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.1] [.t bbox 3.0] $tk_textRelayout +} {{5 18 1 13} {} {5 31 1 13} {1.0 2.0 3.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 + # requested. The "overrideredirect" gets rid of the titlebar so + # the toplevel can shrink to the appropriate size. On Unix, setting + # the overrideredirect on "." confuses the window manager and + # causes subsequent tests to fail. + + if {$tcl_platform(platform) == "windows"} { + wm overrideredirect . 1 + } + frame .f2 -width 20 -height 100 + pack before .f .f2 top + wm geom . 103x103 + update + .t configure -wrap none -borderwidth 2 + .t delete 1.0 end + .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" + update + set x [list [.t bbox 1.0] [.t bbox 2.0] $tk_textRelayout] + wm overrideredirect . 0 + update + set x +} {{5 5 1 1} {} 1.0} +catch {destroy .f2} +.t configure -borderwidth 0 -wrap char +wm geom . {} +update +test textDisp-4.7 {UpdateDisplayInfo, filling in extra vertical space} { + # This test was failing on Windows because the title bar on . + # was a certain minimum size and it was interfering with the size + # requested. The "overrideredirect" gets rid of the titlebar so + # the toplevel can shrink to the appropriate size. On Unix, setting + # the overrideredirect on "." confuses the window manager and + # causes subsequent tests to fail. + + if {$tcl_platform(platform) == "windows"} { + wm overrideredirect . 1 + } + .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 1.0 + update + .t yview 16.0 + update + set x [list [.t index @0,0] $tk_textRelayout $tk_textRedraw] + wm overrideredirect . 0 + update + set x +} {8.0 {16.0 17.0 15.0 14.0 13.0 12.0 11.0 10.0 9.0 8.0} {8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 16.0 17.0}} +test textDisp-4.8 {UpdateDisplayInfo, filling in extra vertical space} { + .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 5.0 14.0 + 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} { + .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}} +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" + .t yview end + update + .t delete 13.0 end + update + list [.t index @0,0] $tk_textRelayout $tk_textRedraw +} {5.0 {12.0 7.0 6.40 6.20 6.0 5.0} {5.0 6.0 6.20 6.40 7.0 12.0}} +test textDisp-4.11 {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, not once but really quite a few times.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" + .t yview end + update + .t delete 14.0 end + update + list [.t index @0,0] $tk_textRelayout $tk_textRedraw +} {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" + button .b -text "Test" -bd 2 -highlightthickness 2 + .t window create 3.end -window .b + .t yview moveto 1 + update + .t yview moveto 0 + update + .t yview moveto 1 + update + winfo ismapped .b +} {0} +.t configure -wrap word +.t delete 1.0 end +.t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5\nLine 6\nLine 7\n" +.t insert end "Line 8\nLine 9\nLine 10\nLine 11\nLine 12\nLine 13\n" +.t insert end "Line 14\nLine 15\nLine 16" +.t tag delete x +.t tag configure x -relief raised -borderwidth 2 -background white +test textDisp-4.13 {UpdateDisplayInfo, special handling for top/bottom lines} { + .t tag add x 1.0 end + .t yview 1.0 + update + .t yview scroll 3 units + update + list $tk_textRelayout $tk_textRedraw +} {{11.0 12.0 13.0} {4.0 10.0 11.0 12.0 13.0}} +test textDisp-4.14 {UpdateDisplayInfo, special handling for top/bottom lines} { + .t tag remove x 1.0 end + .t yview 1.0 + update + .t yview scroll 3 units + update + list $tk_textRelayout $tk_textRedraw +} {{11.0 12.0 13.0} {11.0 12.0 13.0}} +test textDisp-4.15 {UpdateDisplayInfo, special handling for top/bottom lines} { + .t tag add x 1.0 end + .t yview 4.0 + update + .t yview scroll -2 units + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 3.0} {2.0 3.0 4.0 11.0}} +test textDisp-4.16 {UpdateDisplayInfo, special handling for top/bottom lines} { + .t tag remove x 1.0 end + .t yview 4.0 + update + .t yview scroll -2 units + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 3.0} {2.0 3.0}} +test textDisp-4.17 {UpdateDisplayInfo, horizontal scrolling} {fonts} { + .t configure -wrap none + .t delete 1.0 end + .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" + .t insert end "\nLine 3\nLine 4" + update + .t xview scroll 3 units + 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} { + .t configure -wrap none + .t delete 1.0 end + .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" + .t insert end "\nLine 3\nLine 4" + update + .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} { + .t configure -wrap none + .t delete 1.0 end + .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" + .t insert end "\nLine 3\nLine 4" + update + .t xview moveto 0 + .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} { + .t configure -wrap none + .t delete 1.0 end + .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" + .t insert end "\nLine 3\nLine 4" + .t xview moveto 0.0 + .t xview scroll 100 units + update + .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} { + .t configure -wrap none + .t delete 1.0 end + .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" + .t insert end "\nLine 3\nLine 4" + .t xview moveto .9 + update + .t xview moveto .6 + update + list $tk_textRelayout $tk_textRedraw +} {{} {}} +test textDisp-4.22 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {fonts} { + .t configure -wrap none + .t delete 1.0 end + .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" + .t insert end "\nLine 3\nLine 4" + .t xview scroll 25 units + 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} { + .t configure -wrap none + .t delete 1.0 end + .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" + .t insert end "\nLine 3\nLine 4" + .t xview scroll 25 units + 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} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz" + .t tag configure spacing -spacing1 8 -spacing3 2 + .t tag add spacing 1.0 end + frame .t.f1 -width 10 -height 4 -bg black + frame .t.f2 -width 10 -height 4 -bg black + frame .t.f3 -width 10 -height 4 -bg black + frame .t.f4 -width 10 -height 4 -bg black + .t window create 1.3 -window .t.f1 -align top + .t window create 1.7 -window .t.f2 -align center + .t window create 2.1 -window .t.f3 -align bottom + .t window create 2.10 -window .t.f4 -align baseline + 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} +.t tag delete spacing + +# Although the following test produces a useful result, its main +# effect is to produce a core dump if Tk doesn't handle display +# relayout that occurs during redisplay. + +test textDisp-5.2 {DisplayDLine, line resizes during display} { + .t delete 1.0 end + frame .t.f -width 20 -height 20 -bd 2 -relief raised + bind .t.f <Configure> {.t.f configure -width 30 -height 30} + .t window create insert -window .t.f + update + list [winfo width .t.f] [winfo height .t.f] +} {30 30} + +.t configure -wrap char +test textDisp-6.1 {scrolling in DisplayText, scroll up} { + .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" + } + update + .t delete 2.0 3.0 + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 10.0} {2.0 10.0}} +test textDisp-6.2 {scrolling in DisplayText, scroll down} { + .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" + } + update + .t insert 2.0 "New Line 2\n" + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 3.0} {2.0 3.0}} +test textDisp-6.3 {scrolling in DisplayText, multiple scrolls} { + .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" + } + update + .t insert 2.end "is so long that it wraps" + .t insert 4.end "is so long that it wraps" + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 2.20 4.0 4.20} {2.0 2.20 4.0 4.20}} +test textDisp-6.4 {scrolling in DisplayText, scrolls interfere} { + .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" + } + update + .t insert 2.end "is so long that it wraps around, not once but three times" + .t insert 4.end "is so long that it wraps" + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 2.20 2.40 2.60 4.0 4.20} {2.0 2.20 2.40 2.60 4.0 4.20 6.0}} +test textDisp-6.5 {scrolling in DisplayText, scroll source obscured} {nonPortable} { + .t configure -wrap char + frame .f2 -bg red + place .f2 -in .t -relx 0.5 -rely 0.5 -relwidth 0.5 -relheight 0.5 + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, a couple of times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t delete 1.6 1.end + update + 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} { + # this test depends on all of the expose events being handled at once + .t configure -wrap char + frame .f2 -bg #ff0000 + place .f2 -in .t -relx 0.2 -rely 0.5 -relwidth 0.5 -relheight 0.5 + .t configure -bd 2 -relief raised + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, a couple of times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t delete 1.6 1.end + destroy .f2 + update + list $tk_textRelayout $tk_textRedraw +} {{1.0 9.0 10.0} {borders 1.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0}} +.t configure -bd 0 +test textDisp-6.7 {DisplayText, vertical scrollbar updates} { + .t configure -wrap char + .t delete 1.0 end + update + set scrollInfo +} {0 1} +test textDisp-6.8 {DisplayText, vertical scrollbar updates} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "Line 1" + update + set scrollInfo "unchanged" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { + .t insert end "\nLine $i" + } + update + set scrollInfo +} {0 0.769231} +.t configure -yscrollcommand {} -xscrollcommand scroll +test textDisp-6.9 {DisplayText, horizontal scrollbar updates} { + .t configure -wrap none + .t delete 1.0 end + update + set scrollInfo unchanged + .t insert end xxxxxxxxx\n + .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n + .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx + update + set scrollInfo +} {0 0.363636} + +# The following group of tests is marked non-portable because +# they result in a lot of extra redisplay under Ultrix. I don't +# know why this is so. + +.t configure -bd 2 -relief raised -wrap char +.t delete 1.0 end +.t insert 1.0 "Line 1 is so long that it wraps around, a couple of times" +foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" +} +test textDisp-7.1 {TkTextRedrawRegion} {nonPortable} { + frame .f2 -bg #ff0000 + place .f2 -in .t -relx 0.2 -relwidth 0.6 -rely 0.22 -relheight 0.55 + update + destroy .f2 + update + list $tk_textRelayout $tk_textRedraw +} {{} {1.40 2.0 3.0 4.0 5.0 6.0}} +test textDisp-7.2 {TkTextRedrawRegion} {nonPortable} { + frame .f2 -bg #ff0000 + place .f2 -in .t -relx 0 -relwidth 0.5 -rely 0 -relheight 0.5 + update + destroy .f2 + update + list $tk_textRelayout $tk_textRedraw +} {{} {borders 1.0 1.20 1.40 2.0 3.0}} +test textDisp-7.3 {TkTextRedrawRegion} {nonPortable} { + frame .f2 -bg #ff0000 + place .f2 -in .t -relx 0.5 -relwidth 0.5 -rely 0.5 -relheight 0.5 + update + destroy .f2 + update + list $tk_textRelayout $tk_textRedraw +} {{} {borders 4.0 5.0 6.0 7.0 8.0}} +test textDisp-7.4 {TkTextRedrawRegion} {nonPortable} { + frame .f2 -bg #ff0000 + place .f2 -in .t -relx 0.4 -relwidth 0.2 -rely 0 -relheight 0.2 \ + -bordermode ignore + update + destroy .f2 + update + list $tk_textRelayout $tk_textRedraw +} {{} {borders 1.0 1.20}} +test textDisp-7.5 {TkTextRedrawRegion} {nonPortable} { + frame .f2 -bg #ff0000 + place .f2 -in .t -relx 0.4 -relwidth 0.2 -rely 1.0 -relheight 0.2 \ + -anchor s -bordermode ignore + update + destroy .f2 + update + list $tk_textRelayout $tk_textRedraw +} {{} {borders 7.0 8.0}} +test textDisp-7.6 {TkTextRedrawRegion} {nonPortable} { + frame .f2 -bg #ff0000 + place .f2 -in .t -relx 0 -relwidth 0.2 -rely 0.55 -relheight 0.2 \ + -anchor w -bordermode ignore + update + destroy .f2 + update + list $tk_textRelayout $tk_textRedraw +} {{} {borders 3.0 4.0 5.0}} +test textDisp-7.7 {TkTextRedrawRegion} {nonPortable} { + frame .f2 -bg #ff0000 + place .f2 -in .t -relx 1.0 -relwidth 0.2 -rely 0.55 -relheight 0.2 \ + -anchor e -bordermode ignore + update + destroy .f2 + update + list $tk_textRelayout $tk_textRedraw +} {{} {borders 3.0 4.0 5.0}} +test textDisp-7.8 {TkTextRedrawRegion} {nonPortable} { + .t delete 1.0 end + .t insert 1.0 "Line 1\nLine 2\nLine 3\nLine 4\nLine 5\nLine 6\n" + frame .f2 -bg #ff0000 + place .f2 -in .t -relx 0.0 -relwidth 0.4 -rely 0.35 -relheight 0.4 \ + -anchor nw -bordermode ignore + update + destroy .f2 + update + list $tk_textRelayout $tk_textRedraw +} {{} {borders 4.0 5.0 6.0 7.0 eof}} +.t configure -bd 0 + +test textDisp-8.1 {TkTextChanged: redisplay whole lines} {fonts} { + .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" + foreach i {3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .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}} +.t configure -wrap char +test textDisp-8.2 {TkTextChanged, redisplay whole lines} { + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, two times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t insert 1.2 xx + update + list $tk_textRelayout $tk_textRedraw +} {{1.0 1.20 1.40} {1.0 1.20 1.40}} +test textDisp-8.3 {TkTextChanged} { + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, two times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t insert 2.0 xx + update + list $tk_textRelayout $tk_textRedraw +} {2.0 2.0} +test textDisp-8.4 {TkTextChanged} { + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, two times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t delete 1.5 + update + list $tk_textRelayout $tk_textRedraw +} {{1.0 1.20 1.40} {1.0 1.20 1.40}} +test textDisp-8.5 {TkTextChanged} { + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, two times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t delete 1.40 1.44 + update + list $tk_textRelayout $tk_textRedraw +} {{1.0 1.20 1.40} {1.0 1.20 1.40}} +test textDisp-8.6 {TkTextChanged} { + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, two times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t delete 1.41 1.44 + update + list $tk_textRelayout $tk_textRedraw +} {{1.0 1.20 1.40} {1.0 1.20 1.40}} +test textDisp-8.7 {TkTextChanged} { + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, two times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t delete 1.2 1.end + update + list $tk_textRelayout $tk_textRedraw +} {{1.0 9.0 10.0} {1.0 9.0 10.0}} +test textDisp-8.8 {TkTextChanged} { + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, two times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t delete 2.2 + update + list $tk_textRelayout $tk_textRedraw +} {2.0 2.0} +test textDisp-8.9 {TkTextChanged} { + .t delete 1.0 end + .t insert 1.0 "Line 1 is so long that it wraps around, two times" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { + .t insert end "\nLine $i" + } + update + .t delete 2.0 3.0 + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 8.0} {2.0 8.0}} +test textDisp-8.10 {TkTextChanged} { + .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" + .t tag add big 2.19 + update + .t delete 2.19 + update + set tk_textRedraw +} {2.0 2.20 eof} +test textDisp-8.11 {TkTextChanged, scrollbar notification when changes are off-screen} { + .t delete 1.0 end + .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n" + .t configure -yscrollcommand scroll + update + set scrollInfo "" + .t insert end "a\nb\nc\n" + update + .t configure -yscrollcommand "" + set scrollInfo +} {0 0.625} + +test textDisp-9.1 {TkTextRedrawTag} { + .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" + update + .t tag add big 2.2 2.4 + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 2.18} {2.0 2.18}} +test textDisp-9.2 {TkTextRedrawTag} {fonts} { + .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" + update + .t tag add big 1.2 2.4 + update + list $tk_textRelayout $tk_textRedraw +} {{1.0 2.0 2.17} {1.0 2.0 2.17}} +test textDisp-9.3 {TkTextRedrawTag} { + .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" + update + .t tag add big 2.2 2.4 + .t tag remove big 1.0 end + update + list $tk_textRelayout $tk_textRedraw +} {2.0 2.0} +test textDisp-9.4 {TkTextRedrawTag} { + .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" + update + .t tag add big 2.2 2.20 + .t tag remove big 1.0 end + update + list $tk_textRelayout $tk_textRedraw +} {2.0 2.0} +test textDisp-9.5 {TkTextRedrawTag} { + .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" + update + .t tag add big 2.2 2.end + .t tag remove big 1.0 end + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 2.20} {2.0 2.20}} +test textDisp-9.6 {TkTextRedrawTag} { + .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" + update + .t tag add big 2.2 3.5 + .t tag remove big 1.0 end + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 2.20 3.0} {2.0 2.20 3.0}} +test textDisp-9.7 {TkTextRedrawTag} { + .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" + .t tag add big 2.19 + update + .t tag remove big 2.19 + update + set tk_textRedraw +} {2.0 2.20 eof} +test textDisp-9.8 {TkTextRedrawTag} {fonts} { + .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" + .t tag add big 1.0 2.0 + update + .t tag add big 2.0 2.5 + update + set tk_textRedraw +} {2.0 2.17} +test textDisp-9.9 {TkTextRedrawTag} {fonts} { + .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" + .t tag add big 1.0 2.0 + update + .t tag add big 1.5 2.5 + update + set tk_textRedraw +} {2.0 2.17} +test textDisp-9.10 {TkTextRedrawTag} { + .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" + .t tag add big 1.0 2.0 + update + set tk_textRedraw {none} + .t tag add big 1.3 1.5 + update + set tk_textRedraw +} {none} +test textDisp-9.11 {TkTextRedrawTag} { + .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" + .t tag add big 1.0 2.0 + update + .t tag add big 1.0 2.0 + update + set tk_textRedraw +} {} + +test textDisp-10.1 {TkTextRelayoutWindow} { + .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" + update + .t configure -bg black + update + 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] +test textDisp-10.2 {TkTextRelayoutWindow} { + toplevel .top -width 300 -height 200 + wm geometry .top +0+0 + text .top.t -font $fixedFont -width 20 -height 10 -relief raised -bd 2 + place .top.t -x 0 -y 0 -width 20 -height 20 + .top.t insert end "First line" + .top.t see insert + tkwait visibility .top.t + place .top.t -width 150 -height 100 + update + .top.t index @0,0 +} {1.0} +catch {destroy .top} + +.t delete 1.0 end +.t insert end "Line 1" +for {set i 2} {$i <= 200} {incr i} { + .t insert end "\nLine $i" +} +update +test textDisp-11.1 {TkTextSetYView} { + .t yview 30.0 + update + .t index @0,0 +} {30.0} +test textDisp-11.2 {TkTextSetYView} { + .t yview 30.0 + update + .t yview 32.0 + update + list [.t index @0,0] $tk_textRedraw +} {32.0 {40.0 41.0}} +test textDisp-11.3 {TkTextSetYView} { + .t yview 30.0 + update + .t yview 28.0 + update + list [.t index @0,0] $tk_textRedraw +} {28.0 {28.0 29.0}} +test textDisp-11.4 {TkTextSetYView} { + .t yview 30.0 + update + .t yview 31.4 + update + list [.t index @0,0] $tk_textRedraw +} {31.0 40.0} +test textDisp-11.5 {TkTextSetYView} { + .t yview 30.0 + update + set tk_textRedraw {} + .t yview -pickplace 31.0 + update + list [.t index @0,0] $tk_textRedraw +} {30.0 {}} +test textDisp-11.6 {TkTextSetYView} { + .t yview 30.0 + update + set tk_textRedraw {} + .t yview -pickplace 28.0 + update + list [.t index @0,0] $tk_textRedraw +} {28.0 {28.0 29.0}} +test textDisp-11.7 {TkTextSetYView} { + .t yview 30.0 + 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}} +test textDisp-11.8 {TkTextSetYView} { + .t yview 30.0 + update + set tk_textRedraw {} + .t yview -pickplace 41.0 + update + list [.t index @0,0] $tk_textRedraw +} {32.0 {40.0 41.0}} +test textDisp-11.9 {TkTextSetYView} { + .t yview 30.0 + update + set tk_textRedraw {} + .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}} +test textDisp-11.10 {TkTextSetYView} { + .t yview 30.0 + update + set tk_textRedraw {} + .t yview 10000.0 + update + list [.t index @0,0] $tk_textRedraw +} {191.0 {191.0 192.0 193.0 194.0 195.0 196.0 197.0 198.0 199.0 200.0}} +test textDisp-11.11 {TkTextSetYView} { + .t yview 195.0 + update + set tk_textRedraw {} + .t yview 197.0 + update + list [.t index @0,0] $tk_textRedraw +} {191.0 {191.0 192.0 193.0 194.0 195.0 196.0}} +test textDisp-11.12 {TkTextSetYView, wrapped line is off-screen} { + .t insert 10.0 "Long line with enough text to wrap\n" + .t yview 1.0 + update + set tk_textRedraw {} + .t see 10.30 + update + 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} { + catch {destroy .top} + toplevel .top + wm geometry .top +0+0 + text .top.t -width 20 -height 5 + pack .top.t + .top.t insert end "Line 1" + for {set i 2} {$i <= 100} {incr i} { + .top.t insert end "\nLine $i" + } + update + scan [wm geometry .top] "%dx%d" w2 h2 + wm geometry .top ${w2}x[expr $h2-2] + update + .top.t yview 1.0 + update + set tk_textRedraw {} + .top.t see 5.0 + update + list [.top.t index @0,0] $tk_textRedraw +} {2.0 {5.0 6.0}} +catch {destroy .top} +toplevel .top +wm geometry .top +0+0 +text .top.t -width 30 -height 3 +pack .top.t +.top.t insert end "Line 1" +for {set i 2} {$i <= 20} {incr i} { + .top.t insert end "\nLine $i" +} +update +test textDisp-11.14 {TkTextSetYView, only a few lines visible} { + .top.t yview 5.0 + update + .top.t see 10.0 + .top.t index @0,0 +} {8.0} +test textDisp-11.15 {TkTextSetYView, only a few lines visible} { + .top.t yview 5.0 + update + .top.t see 11.0 + .top.t index @0,0 +} {10.0} +test textDisp-11.16 {TkTextSetYView, only a few lines visible} { + .top.t yview 8.0 + update + .top.t see 5.0 + .top.t index @0,0 +} {5.0} +test textDisp-11.17 {TkTextSetYView, only a few lines visible} { + .top.t yview 8.0 + update + .top.t see 4.0 + .top.t index @0,0 +} {3.0} +destroy .top + +.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-12.1 {MeasureUp} { + .t yview 100.0 + update + .t yview -pickplace 52.0 + update + .t index @0,0 +} {50.0} +test textDisp-12.2 {MeasureUp} { + .t yview 100.0 + update + .t yview -pickplace 53.0 + update + .t index @0,0 +} {50.15} +test textDisp-12.3 {MeasureUp} { + .t yview 100.0 + update + .t yview -pickplace 50.10 + update + .t index @0,0 +} {46.0} +.t configure -wrap none +test textDisp-12.4 {MeasureUp} { + .t yview 100.0 + update + .t yview -pickplace 53.0 + update + .t index @0,0 +} {49.0} +test textDisp-12.5 {MeasureUp} { + .t yview 100.0 + update + .t yview -pickplace 50.10 + update + .t index @0,0 +} {46.0} + +.t configure -wrap none +.t delete 1.0 end +for {set i 1} {$i < 99} {incr i} { + .t insert end "Line $i\n" +} +.t insert end "Line 100" +.t insert 30.end { is quite long, so that it flows way off the end of the window and we can use it to test out the horizontal positioning features of the "see" command.} +test textDisp-13.1 {TkTextSeeCmd procedure} { + list [catch {.t see} msg] $msg +} {1 {wrong # args: should be ".t see index"}} +test textDisp-13.2 {TkTextSeeCmd procedure} { + list [catch {.t see a b} msg] $msg +} {1 {wrong # args: should be ".t see index"}} +test textDisp-13.3 {TkTextSeeCmd procedure} { + list [catch {.t see badIndex} msg] $msg +} {1 {bad text index "badIndex"}} +test textDisp-13.4 {TkTextSeeCmd procedure} { + .t xview moveto 0 + .t yview moveto 0 + update + .t see 4.2 + .t index @0,0 +} {1.0} +test textDisp-13.5 {TkTextSeeCmd procedure} { + .t configure -wrap char + .t xview moveto 0 + .t yview moveto 0 + update + .t see 12.1 + .t index @0,0 +} {3.0} +test textDisp-13.6 {TkTextSeeCmd procedure} { + .t configure -wrap char + .t xview moveto 0 + .t yview moveto 0 + update + .t see 30.50 + set x [.t index @0,0] + .t configure -wrap none + set x +} {28.0} +test textDisp-13.7 {TkTextSeeCmd procedure} {fonts} { + .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 + set x [list [.t bbox 30.50]] + .t see 30.39 + lappend x [.t bbox 30.39] + .t see 30.38 + 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} { + .t xview moveto 0 + .t yview moveto 0 + .t tag add sel 30.20 + .t tag add sel 30.50 + update + .t see 30.50 + set x [list [.t bbox 30.50]] + .t see 30.60 + lappend x [.t bbox 30.60] + .t see 30.65 + 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} { + wm geom . [expr $width-2]x$height + .t xview moveto 0 + .t yview moveto 0 + .t tag add sel 30.20 + .t tag add sel 30.50 + update + .t see 30.50 + set x [list [.t bbox 30.50]] + .t see 30.60 + lappend x [.t bbox 30.60] + .t see 30.65 + 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}} +wm geom . {} + +.t configure -wrap none +test textDisp-14.1 {TkTextXviewCmd procedure} { + .t delete 1.0 end + update + .t insert end xxxxxxxxx\n + .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" + .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" + .t xview moveto .5 + .t xview +} {0.5 0.857143} +.t configure -wrap char +test textDisp-14.2 {TkTextXviewCmd procedure} { + .t delete 1.0 end + update + .t insert end xxxxxxxxx\n + .t insert end "xxxxx\n" + .t insert end "xxxx" + .t xview +} {0 1} +.t configure -wrap none +test textDisp-14.3 {TkTextXviewCmd procedure} { + .t delete 1.0 end + update + .t insert end xxxxxxxxx\n + .t insert end "xxxxx\n" + .t insert end "xxxx" + .t xview +} {0 1} +test textDisp-14.4 {TkTextXviewCmd procedure} { + list [catch {.t xview moveto} msg] $msg +} {1 {wrong # args: should be ".t xview moveto fraction"}} +test textDisp-14.5 {TkTextXviewCmd procedure} { + list [catch {.t xview moveto a b} msg] $msg +} {1 {wrong # args: should be ".t xview moveto fraction"}} +test textDisp-14.6 {TkTextXviewCmd procedure} { + list [catch {.t xview moveto a} msg] $msg +} {1 {expected floating-point number but got "a"}} +test textDisp-14.7 {TkTextXviewCmd procedure} { + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" + .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" + .t xview moveto .3 + .t xview +} {0.303571 0.660714} +test textDisp-14.8 {TkTextXviewCmd procedure} { + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" + .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" + .t xview moveto -.4 + .t xview +} {0 0.357143} +test textDisp-14.9 {TkTextXviewCmd procedure} { + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" + .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" + .t xview m 1.4 + .t xview +} {0.642857 1} +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"}} +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"}} +test textDisp-14.12 {TkTextXviewCmd procedure} { + list [catch {.t xview scroll gorp units} msg] $msg +} {1 {expected integer but got "gorp"}} +test textDisp-14.13 {TkTextXviewCmd procedure} { + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .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 + set x [.t index @0,22] + .t xview scroll -1 p + lappend x [.t index @0,22] + .t xview scroll -2 pages + lappend x [.t index @0,22] +} {2.36 2.18 2.0} +test textDisp-14.14 {TkTextXviewCmd procedure} { + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .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 21 u + set x [.t index @0,22] + .t xview scroll -1 u + lappend x [.t index @0,22] + .t xview scroll 100 units + lappend x [.t index @0,22] + .t xview scroll -15 units + lappend x [.t index @0,22] +} {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}} +test textDisp-14.16 {TkTextXviewCmd procedure} { + list [catch {.t xview flounder} msg] $msg +} {1 {unknown option "flounder": must be moveto or scroll}} + +.t configure -wrap char +.t delete 1.0 end +for {set i 1} {$i < 99} {incr i} { + .t insert end "Line $i\n" +} +.t insert end "Line 100" +.t delete 50.0 51.0 +.t insert 50.0 "This is a long line, one that will wrap around twice.\n" +test textDisp-15.1 {ScrollByLines procedure, scrolling backwards} { + .t yview 45.0 + update + .t yview scroll -3 units + .t index @0,0 +} {42.0} +test textDisp-15.2 {ScrollByLines procedure, scrolling backwards} { + .t yview 51.0 + update + .t yview scroll -2 units + .t index @0,0 +} {50.20} +test textDisp-15.3 {ScrollByLines procedure, scrolling backwards} { + .t yview 51.0 + update + .t yview scroll -4 units + .t index @0,0 +} {49.0} +test textDisp-15.4 {ScrollByLines procedure, scrolling backwards} { + .t yview 50.20 + update + .t yview scroll -2 units + .t index @0,0 +} {49.0} +test textDisp-15.5 {ScrollByLines procedure, scrolling backwards} { + .t yview 50.40 + update + .t yview scroll -2 units + .t index @0,0 +} {50.0} +test textDisp-15.6 {ScrollByLines procedure, scrolling backwards} { + .t yview 3.2 + update + .t yview scroll -5 units + .t index @0,0 +} {1.0} +test textDisp-15.7 {ScrollByLines procedure, scrolling forwards} { + .t yview 48.0 + update + .t yview scroll 4 units + .t index @0,0 +} {50.40} + +.t configure -wrap char +.t delete 1.0 end +.t insert insert "Line 1" +for {set i 2} {$i <= 200} {incr i} { + .t insert end "\nLine $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 +test textDisp-16.1 {TkTextYviewCmd procedure} { + .t yview 21.0 + set x [.t yview] + .t yview 1.0 + set x +} {0.1 0.15} +test textDisp-16.2 {TkTextYviewCmd procedure} { + list [catch {.t yview 2 3} msg] $msg +} {1 {unknown 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"}} +test textDisp-16.4 {TkTextYviewCmd procedure} { + list [catch {.t yview -pickplace 2 3} msg] $msg +} {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}} +test textDisp-16.6 {TkTextYviewCmd procedure, integer position} { + .t yview 100.0 + update + .t yview 98 + .t index @0,0 +} {99.0} +test textDisp-16.7 {TkTextYviewCmd procedure} { + .t yview 2.0 + .t yv -pickplace 13.0 + .t index @0,0 +} {4.0} +test textDisp-16.8 {TkTextYviewCmd procedure} { + list [catch {.t yview bad_mark_name} msg] $msg +} {1 {bad text index "bad_mark_name"}} +test textDisp-16.9 {TkTextYviewCmd procedure, "moveto" option} { + list [catch {.t yview moveto a b} msg] $msg +} {1 {wrong # args: should be ".t yview moveto fraction"}} +test textDisp-16.10 {TkTextYviewCmd procedure, "moveto" option} { + list [catch {.t yview moveto gorp} msg] $msg +} {1 {expected floating-point number but got "gorp"}} +test textDisp-16.11 {TkTextYviewCmd procedure, "moveto" option} { + .t yview moveto 0.5 + .t index @0,0 +} {101.0} +test textDisp-16.12 {TkTextYviewCmd procedure, "moveto" option} { + .t yview moveto -1 + .t index @0,0 +} {1.0} +test textDisp-16.13 {TkTextYviewCmd procedure, "moveto" option} { + .t yview moveto 1.1 + .t index @0,0 +} {191.0} +test textDisp-16.14 {TkTextYviewCmd procedure, "moveto" option} { + .t yview moveto .75 + .t index @0,0 +} {151.0} +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 + .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} { + catch {destroy .top1} + toplevel .top1 + wm geometry .top1 +0+0 + text .top1.t -height 3 -width 4 -wrap none -setgrid 1 -padx 6 \ + -spacing3 6 + .top1.t insert end "1\n2\n3\n4\n5\n6" + pack .top1.t + update + .top1.t yview moveto 0.3333 + set result [.top1.t yview] + destroy .top1 + set result +} {0.333333 0.833333} +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"}} +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"}} +test textDisp-16.21 {TkTextYviewCmd procedure, "scroll" option} { + list [catch {.t yview scroll badInt bogus} msg] $msg +} {1 {expected integer but got "badInt"}} +test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { + .t yview 50.0 + update + .t yview scroll -1 pages + .t index @0,0 +} {42.0} +test textDisp-16.23 {TkTextYviewCmd procedure, "scroll" option, back pages} { + .t yview 50.0 + update + .t yview scroll -3 p + .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 index @0,0 +} {1.0} +test textDisp-16.25 {TkTextYviewCmd procedure, "scroll" option, back pages} { + .t configure -height 1 + update + .t yview 50.0 + update + .t yview scroll -1 pages + set x [.t index @0,0] + .t configure -height 10 + update + set x +} {49.0} +test textDisp-16.26 {TkTextYviewCmd procedure, "scroll" option, forward pages} { + .t yview 50.0 + update + .t yview scroll 1 pages + .t index @0,0 +} {58.0} +test textDisp-16.27 {TkTextYviewCmd procedure, "scroll" option, forward pages} { + .t yview 50.0 + update + .t yview scroll 2 pages + .t index @0,0 +} {66.0} +test textDisp-16.28 {TkTextYviewCmd procedure, "scroll" option, forward pages} {fonts} { + .t yview 98.0 + update + .t yview scroll 1 page + .t index @0,0 +} {103.0} +test textDisp-16.29 {TkTextYviewCmd procedure, "scroll" option, forward pages} { + .t configure -height 1 + update + .t yview 50.0 + update + .t yview scroll 1 pages + set x [.t index @0,0] + .t configure -height 10 + update + set x +} {51.0} +test textDisp-16.30 {TkTextYviewCmd procedure, "scroll units" option} { + .t yview 45.0 + update + .t yview scroll -3 units + .t index @0,0 +} {42.0} +test textDisp-16.31 {TkTextYviewCmd procedure, "scroll units" option} { + .t yview 149.0 + update + .t yview scroll 4 units + .t index @0,0 +} {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}} +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}} + +.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} { + .t insert end "\nLine $i 11111 $i 22222 $i 33333 $i 44444 $i 55555" + .t insert end " $i 66666 $i 77777 $i 88888 $i" +} +.t configure -wrap none +test textDisp-17.1 {TkTextScanCmd procedure} { + list [catch {.t scan a b} msg] $msg +} {1 {wrong # args: should be ".t scan mark|dragto x y"}} +test textDisp-17.2 {TkTextScanCmd procedure} { + list [catch {.t scan a b c d} msg] $msg +} {1 {wrong # args: should be ".t scan mark|dragto x y"}} +test textDisp-17.3 {TkTextScanCmd procedure} { + list [catch {.t scan stupid b 20} msg] $msg +} {1 {expected integer but got "b"}} +test textDisp-17.4 {TkTextScanCmd procedure} { + list [catch {.t scan stupid -2 bogus} msg] $msg +} {1 {expected integer but got "bogus"}} +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} { + .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} { + .t yview 10.0 + .t xview moveto 0 + .t xview scroll 20 units + .t scan mark -10 60 + .t scan dragto -5 65 + .t index @0,0 + set x [.t index @0,0] + .t scan dragto 0 70 + list $x [.t index @0,0] +} {7.13 3.6} +test textDisp-17.8 {TkTextScanCmd procedure} {fonts} { + .t yview 1.0 + .t xview moveto 0 + .t scan mark 0 60 + .t scan dragto 30 100 + .t scan dragto 25 95 + .t index @0,0 +} {4.7} +test textDisp-17.9 {TkTextScanCmd procedure} {fonts} { + .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 index @0,0 +} {18.44} +.t configure -wrap word +test textDisp-17.10 {TkTextScanCmd procedure, word wrapping} {fonts} { + .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 + list $x [.t index @0,0] +} {9.31 8.47} + +.t configure -xscrollcommand scroll -yscrollcommand {} +test textDisp-18.1 {GetXView procedure} { + .t configure -wrap none + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n + .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx + update + set scrollInfo +} {0 0.363636} +test textDisp-18.2 {GetXView procedure} { + .t configure -wrap char + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n + .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx + update + set scrollInfo +} {0 1} +test textDisp-18.3 {GetXView procedure} { + .t configure -wrap none + .t delete 1.0 end + update + set scrollInfo +} {0 1} +test textDisp-18.4 {GetXView procedure} { + .t configure -wrap none + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .t insert end xxxxxx\n + .t insert end xxxxxxxxxxxxxxxxx + update + set scrollInfo +} {0 1} +test textDisp-18.5 {GetXView procedure} { + .t configure -wrap none + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n + .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx + .t xview scroll 31 units + update + set scrollInfo +} {0.563636 0.927273} +test textDisp-18.6 {GetXView procedure} { + .t configure -wrap none + .t delete 1.0 end + .t insert end xxxxxxxxx\n + .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" + .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" + .t xview moveto 0 + .t xview scroll 31 units + update + set x {} + lappend x $scrollInfo + .t configure -wrap char + update + lappend x $scrollInfo + .t configure -wrap word + update + lappend x $scrollInfo + .t configure -wrap none + update + lappend x $scrollInfo +} {{0.553571 0.910714} {0 1} {0 1} {0 0.357143}} +test textDisp-18.7 {GetXView procedure} { + .t configure -wrap none + .t delete 1.0 end + update + set scrollInfo unchanged + .t insert end xxxxxx\n + .t insert end xxx + update + set scrollInfo +} {unchanged} +test textDisp-18.8 {GetXView procedure} { + proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] + } + proc bogus args { + error "bogus scroll proc" + } + .t configure -wrap none + .t delete 1.0 end + .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n + update + .t delete 1.0 end + .t configure -xscrollcommand scrollError + update + set x +} {{scrolling error} {scrolling error + while executing +"error "scrolling error"" + (procedure "scrollError" line 2) + invoked from within +"scrollError 0 1" + (horizontal scrolling command executed by text)}} +catch {rename bgerror {}} +catch {rename bogus {}} +.t configure -xscrollcommand {} -yscrollcommand scroll + +.t configure -xscrollcommand {} -yscrollcommand scroll +test textDisp-19.1 {GetYView procedure} { + .t configure -wrap char + .t delete 1.0 end + update + set scrollInfo +} {0 1} +test textDisp-19.2 {GetYView procedure} { + .t configure -wrap char + .t delete 1.0 end + update + set scrollInfo "unchanged" + .t insert 1.0 "Line1\nLine2" + update + set scrollInfo +} {unchanged} +test textDisp-19.3 {GetYView procedure} { + .t configure -wrap char + .t delete 1.0 end + update + set scrollInfo "unchanged" + .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around\nLine 3" + update + set scrollInfo +} {unchanged} +test textDisp-19.4 {GetYView procedure} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "Line 1" + update + set scrollInfo "unchanged" + foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { + .t insert end "\nLine $i" + } + update + set scrollInfo +} {0 0.769231} +test textDisp-19.5 {GetYView procedure} { + .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} { + .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 + set x $scrollInfo +} {0 0.538462} +test textDisp-19.6 {GetYView procedure} { + .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} { + .t insert end "\nLine $i" + } + .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" + .t yview 4.0 + update + set x $scrollInfo +} {0.230769 1} +test textDisp-19.7 {GetYView procedure} { + .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} { + .t insert end "\nLine $i" + } + .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" + .t yview 2.26 + update + set x $scrollInfo +} {0.097166 0.692308} +test textDisp-19.8 {GetYView procedure} { + .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} { + .t insert end "\nLine $i" + } + .t insert 10.end " is really quite long; in fact it's so long that it wraps three times" + .t yview 2.0 + update + set x $scrollInfo +} {0.0769231 0.732268} +test textDisp-19.9 {GetYView procedure} { + .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 3.0 + update + set scrollInfo +} {0.133333 0.8} +test textDisp-19.10 {GetYView procedure} { + .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 + set scrollInfo +} {0.333333 1} +test textDisp-19.11 {GetYView procedure} { + .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 + set scrollInfo +} {0.625 1} +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 + pack .top.t -expand yes -fill both + .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5" + update + 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} { + catch {destroy .top} + toplevel .top + wm geometry .top +0+0 + text .top.t -width 40 -height 5 + 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 + scan [wm geom .top] %dx%d twidth theight + wm geom .top ${twidth}x[expr $theight - 3] + update + .top.t yview +} {0 0.942308} +catch {destroy .top} +test textDisp-19.14 {GetYView procedure} { + .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." + update + set scrollInfo "unchanged" + .t mark set insert 3.0 + .t tag configure x -background red + .t tag add x 1.0 5.0 + update + .t tag delete x + set scrollInfo +} {unchanged} +test textDisp-19.15 {GetYView procedure} { + .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." + update + .t configure -yscrollcommand scrollError + proc bgerror args { + global x errorInfo errorCode + set x [list $args $errorInfo $errorCode] + } + .t delete 1.0 end + update + rename bgerror {} + .t configure -yscrollcommand scroll + set x +} {{{scrolling error}} {scrolling error + while executing +"error "scrolling error"" + (procedure "scrollError" line 2) + invoked from within +"scrollError 0 1" + (vertical scrolling command executed by text)} NONE} + +.t delete 1.0 end +.t insert end "Line 1" +for {set i 2} {$i <= 200} {incr i} { + .t insert end "\nLine $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} { + .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} { + .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} { + .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} { + .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} {}} +.t config -wrap none +test textDisp-20.5 {FindDLine} {fonts} { + .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}} + +.t config -wrap word +test textDisp-21.1 {TkTextPixelIndex} {fonts} { + .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] +} {48.0 48.0 48.2 48.7 50.40 50.40} +.t insert end \n +test textDisp-21.2 {TkTextPixelIndex} {fonts} { + .t yview 195.0 + list [.t index @11,70] [.t index @11,84] [.t index @11,102] \ + [.t index @11,1002] +} {197.1 198.1 199.1 201.0} +test textDisp-21.3 {TkTextPixelIndex, horizontal scrolling} {fonts} { + .t configure -wrap none + .t delete 1.0 end + .t insert end "12345\n" + .t insert end "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + .t xview scroll 2 units + list [.t index @-5,7] [.t index @5,7] [.t index @33,20] +} {1.2 1.2 2.6} + +.t delete 1.0 end +.t insert end "Line 1" +for {set i 2} {$i <= 200} {incr i} { + .t insert end "\nLine $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" +update +.t tag add x 50.1 +test textDisp-22.1 {TkTextCharBbox} {fonts} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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}} +wm geom . {} +update +test textDisp-22.7 {TkTextCharBbox, different character sizes} {fonts} { + .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}} +.t tag remove big 1.0 end +test textDisp-22.8 {TkTextCharBbox, horizontal scrolling} {fonts} { + .t configure -wrap none + .t delete 1.0 end + .t insert end "12345\n" + .t insert end "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + .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} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz" + .t tag configure spacing -spacing1 8 -spacing3 2 + .t tag add spacing 1.0 end + frame .t.f1 -width 10 -height 4 -bg black + frame .t.f2 -width 10 -height 4 -bg black + frame .t.f3 -width 10 -height 4 -bg black + frame .t.f4 -width 10 -height 4 -bg black + .t window create 1.3 -window .t.f1 -align top + .t window create 1.7 -window .t.f2 -align center + .t window create 2.1 -window .t.f3 -align bottom + .t window create 2.10 -window .t.f4 -align baseline + 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}} +.t tag delete spacing + +.t delete 1.0 end +.t insert end "Line 1" +for {set i 2} {$i <= 200} {incr i} { + .t insert end "\nLine $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" +update +test textDisp-23.1 {TkTextDLineInfo} {fonts} { + .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} { + .t config -bd 4 -wrap word + update + .t yview 48.0 + .t dlineinfo 50.40 +} {7 59 126 13 10} +.t config -bd 0 +test textDisp-23.3 {TkTextDLineInfo} {fonts} { + .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} { + .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} { + .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}} +wm geom . {} +update +test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} {fonts} { + .t config -wrap none + .t delete 1.0 end + .t insert end "First line\n" + .t insert end "Second line is a very long one that doesn't all fit.\n" + .t insert end "Third" + .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}} +.t xview moveto 0 +test textDisp-23.7 {TkTextDLineInfo, centering} {fonts} { + .t config -wrap word + .t delete 1.0 end + .t insert end "First line\n" + .t insert end "Second line is a very long one that doesn't all fit.\n" + .t insert end "Third" + .t tag configure x -justify center + .t tag configure y -justify right + .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}} +.t tag delete x y + +test textDisp-24.1 {TkTextCharLayoutProc} {fonts} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "01234567890123456789 \nabcdefg" + wm geom . [expr $width-2]x$height + update + set result {} + 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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .t configure -wrap none + .t delete 1.0 end + .t insert 1.0 "Line 1\nLine 2\nLine 3" + set result {} + lappend result [.t bbox 2.1] [.t dlineinfo 2.1] + .t tag configure up -offset 6 + .t tag add up 2.1 + lappend result [.t bbox 2.1] [.t dlineinfo 2.1] + .t tag configure up -offset -2 + 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}} +.t configure -width 30 +update +test textDisp-24.21 {TkTextCharLayoutProc, word breaks} {fonts} { + .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} { + .t configure -wrap word + .t delete 1.0 end + frame .t.f -width 30 -height 20 -bg black + .t insert 1.0 "Sample text xxxxxxx yyyyyyy" + .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} { + .t configure -wrap word + .t delete 1.0 end + frame .t.f -width 30 -height 20 -bg black + .t insert 1.0 "Sample text xxxxxxx yyyyyyy " + .t insert end "zzzzzzz qqqqq rrrr ssss tt" + .t window create end -window .t.f + .t insert end "u vvvvv" + .t bbox .t.f +} {3 29 30 20} +catch {destroy .t.f} +.t configure -width 20 +update +test textDisp-24.24 {TkTextCharLayoutProc, justification and tabs} {fonts} { + .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}} + +.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} { + .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}} + +.t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \ + -tabs {} +update +test textDisp-26.1 {AdjustForTab procedure, no tabs} {fonts} { + .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} +test textDisp-26.2 {AdjustForTab procedure, not enough tabs specified} { + .t delete 1.0 end + .t insert 1.0 a\tb\tc\td + .t tag delete x + .t tag configure x -tabs 40 + .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} +test textDisp-26.3 {AdjustForTab procedure, not enough tabs specified} { + .t delete 1.0 end + .t insert 1.0 a\tb\tc\td\te + .t tag delete x + .t tag configure x -tabs {40 70 right} + .t tag add x 1.0 end + list [lindex [.t bbox 1.2] 0] \ + [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} +test textDisp-26.4 {AdjustForTab procedure, different alignments} { + .t delete 1.0 end + .t insert 1.0 a\tbc\tde\tfg\thi + .t tag delete x + .t tag configure x -tabs {40 center 80 left 130 right} + .t tag add x 1.0 end + .t tag add y 1.2 + .t tag add y 1.5 + .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} +test textDisp-26.5 {AdjustForTab procedure, numeric alignment} { + .t delete 1.0 end + .t insert 1.0 a\t1.234 + .t tag delete x + .t tag configure x -tabs {120 numeric} + .t tag add x 1.0 end + .t tag add y 1.2 + .t tag add y 1.5 + lindex [.t bbox 1.3] 0 +} {120} +test textDisp-26.6 {AdjustForTab procedure, numeric alignment} { + .t delete 1.0 end + .t insert 1.0 a\t1,456.234 + .t tag delete x + .t tag configure x -tabs {120 numeric} + .t tag add x 1.0 end + .t tag add y 1.2 + lindex [.t bbox 1.7] 0 +} {120} +test textDisp-26.7 {AdjustForTab procedure, numeric alignment} { + .t delete 1.0 end + .t insert 1.0 a\t1.456.234,7 + .t tag delete x + .t tag configure x -tabs {120 numeric} + .t tag add x 1.0 end + .t tag add y 1.2 + lindex [.t bbox 1.11] 0 +} {120} +test textDisp-26.8 {AdjustForTab procedure, numeric alignment} { + .t delete 1.0 end + .t insert 1.0 a\ttest + .t tag delete x + .t tag configure x -tabs {120 numeric} + .t tag add x 1.0 end + .t tag add y 1.2 + lindex [.t bbox 1.6] 0 +} {120} +test textDisp-26.9 {AdjustForTab procedure, numeric alignment} { + .t delete 1.0 end + .t insert 1.0 a\t1234 + .t tag delete x + .t tag configure x -tabs {120 numeric} + .t tag add x 1.0 end + .t tag add y 1.2 + lindex [.t bbox 1.6] 0 +} {120} +test textDisp-26.10 {AdjustForTab procedure, numeric alignment} { + .t delete 1.0 end + .t insert 1.0 a\t1.234567 + .t tag delete x + .t tag configure x -tabs {120 numeric} + .t tag add x 1.0 end + .t tag add y 1.5 + lindex [.t bbox 1.3] 0 +} {120} +test textDisp-26.11 {AdjustForTab procedure, numeric alignment} { + .t delete 1.0 end + .t insert 1.0 a\tx=1.234567 + .t tag delete x + .t tag configure x -tabs {120 numeric} + .t tag add x 1.0 end + .t tag add y 1.7 + .t tag add y 1.9 + lindex [.t bbox 1.5] 0 +} {120} +test textDisp-26.12 {AdjustForTab procedure, adjusting chunks} { + .t delete 1.0 end + .t insert 1.0 a\tx1.234567 + .t tag delete x + .t tag configure x -tabs {120 numeric} + .t tag add x 1.0 end + .t tag add y 1.7 + .t tag add y 1.9 + button .b -text "=" + .t window create 1.3 -window .b + update + lindex [.t bbox 1.5] 0 +} {120} +test textDisp-26.13 {AdjustForTab procedure, not enough space} {fonts} { + .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} + .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} + +.t configure -width 20 -bd 2 -highlightthickness 2 -relief sunken -tabs {} \ + -wrap char +update +test textDisp-27.1 {SizeOfTab procedure, old-style tabs} {fonts} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .t delete 1.0 end + .t configure -tabs {1c 2c center 3c 4c} -wrap none -width 40 + .t insert 1.0 a\tb\tc\td\te\n012345678934567890a\tbb\tcc\tdd + update + .t bbox 2.24 +} {172 18 7 13} +.t configure -wrap char -tabs {} -width 20 +update +test textDisp-27.8 {SizeOfTab procedure, right alignment} {fonts} { + .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} { + .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} { + .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} { + .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}} + +proc bizarre_scroll args { + .t2.t delete 5.0 end +} +test textDisp-28.1 {"yview" option with bizarre scroll command} { + catch {destroy .t2} + toplevel .t2 + text .t2.t -width 40 -height 4 + .t2.t insert end "1\n2\n3\n4\n5\n6\n7\n8\n" + pack .t2.t + wm geometry .t2 +0+0 + update + .t2.t configure -yscrollcommand bizarre_scroll + .t2.t yview 100.0 + set result [.t2.t index @0,0] + update + lappend result [.t2.t index @0,0] +} {6.0 1.0} + +test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {fonts} { + 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 + 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} { + 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 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} { + 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 + update + .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 {}} + +foreach i [winfo children .] { + catch {destroy $i} +} +option clear diff --git a/tests/textImage.test b/tests/textImage.test new file mode 100644 index 0000000..80d083c --- /dev/null +++ b/tests/textImage.test @@ -0,0 +1,353 @@ +# SCCS: @(#) textImage.test 1.8 97/07/01 18:11:54 + +if {[string compare test [info procs test]] == 1} then \ + {source ../tests/defs} + +# Test Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "testConfig". If any of these +# elements is zero, the test is skipped. +# This argument may be omitted. +# script - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. +# answer - Expected result from script. + +# One time setup. Create a font to insure the tests are font metric invariant. + +wm geometry . {} +catch {destroy .t} +font create test_font -family courier -size 14 +text .t -font test_font +destroy .t + +test textImage-1.1 {basic argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image} msg] $msg +} {1 {wrong # args: should be ".t image option ?arg arg ...?"}} + +test textImage-1.2 {basic argument checking} { + catch {destroy .t} + 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}} + +test textImage-1.3 {cget argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image cget} msg] $msg +} {1 {wrong # args: should be ".t image cget index option"}} + +test textImage-1.4 {cget argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image cget blurf -flurp} msg] $msg +} {1 {bad text index "blurf"}} + +test textImage-1.5 {cget argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image cget 1.1 -flurp} msg] $msg +} {1 {no embedded image at index "1.1"}} + +test textImage-1.6 {configure argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image configure } msg] $msg +} {1 {wrong # args: should be ".t image configure index ?option value ...?"}} + +test textImage-1.7 {configure argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image configure blurf } msg] $msg +} {1 {bad text index "blurf"}} + +test textImage-1.8 {configure argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image configure 1.1 } msg] $msg +} {1 {no embedded image at index "1.1"}} + +test textImage-1.9 {create argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image create} msg] $msg +} {1 {wrong # args: should be ".t image create index ?option value ...?"}} + +test textImage-1.10 {create argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image create blurf } msg] $msg +} {1 {bad text index "blurf"}} + +test textImage-1.11 {basic argument checking} { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image create 1000.1000 -image small} msg] $msg +} {0 small} + +test textImage-1.12 {names argument checking} { + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + list [catch {.t image names dates places} msg] $msg +} {1 {wrong # args: should be ".t image names"}} + + +test textImage-1.13 {names argument checking} { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + set result "" + lappend result [.t image names] + .t image create insert -image small + lappend result [.t image names] + .t image create insert -image small + lappend result [.t image names] + .t image create insert -image small -name little + lappend result [.t image names] +} {{} small {small#1 small} {small#1 small little}} + +test textImage-1.14 {basic argument checking} { + catch {destroy .t} + 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}} + +test textImage-1.15 {align argument checking} { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + catch {destroy .t} + 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}} + +test textImage-1.16 {configure} { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image small + .t image configure small +} {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}} + +test textImage-1.17 {basic cget options} { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image small + set result "" + foreach i {align padx pady image name} { + lappend result $i:[.t image cget small -$i] + } + set result +} {align:center padx:0 pady:0 image:small name:} + +test textImage-1.18 {basic configure options} { + 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} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image small + set result "" + foreach {option value} {align top padx 5 pady 7 image large name none} { + .t image configure small -$option $value + } + update + .t image configure small +} {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}} + +test textImage-1.19 {basic image naming} { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image small + .t image create end -image small -name small + .t image create end -image small -name small#6342 + .t image create end -image small -name small + lsort [.t image names] +} {small small#1 small#6342 small#6343} + +test textImage-2.1 {debug} { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t debug 1 + .t insert end front + .t image create end -image small + .t insert end back + .t delete small + .t image names + .t debug 0 +} {} + +test textImage-3.1 {image change propagation} { + catch { + image create photo vary -width 5 -height 5 + small put red -to 0 0 4 4 + } + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image vary -align top + update + set result "" + lappend result base:[.t bbox vary] + foreach i {10 20 40} { + vary configure -width $i -height $i + update + lappend result $i:[.t bbox vary] + } + set result +} {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}} + +test textImage-3.2 {delayed image management} { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + catch {destroy .t} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -name test + update + set result "" + lappend result [.t bbox test] + .t image configure test -image small -align top + update + lappend result [.t bbox test] +} {{} {0 0 5 5}} + +# some temporary random tests + +test textImage-4.1 {alignment checking - except baseline} { + 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} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image large + .t image create end -image small + .t insert end test + update + set result "" + lappend result default:[.t bbox small] + foreach i {top bottom center} { + .t image configure small -align $i + update + lappend result [.t image cget small -align]:[.t bbox small] + } + set result +} {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}} + +test textImage-4.2 {alignment checking - baseline} { + 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} + font create test_font2 -size 5 + text .t -font test_font2 -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image large + .t image create end -image small -align baseline + .t insert end test + set result "" + foreach size {10 15 20 30} { + font configure test_font2 -size $size + array set Metrics [font metrics test_font2] + update + foreach {x y w h} [.t bbox small] {} + set norm [expr { + (([image height large] - $Metrics(-linespace))/2 + + $Metrics(-ascent) - [image height small] - $y) + }] + lappend result "$size $norm" + } + font delete test_font2 + unset Metrics + set result +} {{10 0} {15 0} {20 0} {30 0}} + +test textImage-4.3 {alignment and padding checking} {fonts} { + 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} + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image large + .t image create end -image small -padx 5 -pady 10 + .t insert end test + update + set result "" + lappend result default:[.t bbox small] + foreach i {top bottom center baseline} { + .t image configure small -align $i + update + lappend result $i:[.t bbox small] + } + 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 + +catch {destroy .t} +foreach image [image names] {image delete $image} +font delete test_font diff --git a/tests/textIndex.test b/tests/textIndex.test new file mode 100644 index 0000000..df30951 --- /dev/null +++ b/tests/textIndex.test @@ -0,0 +1,349 @@ +# This file is a Tcl script to test the code in the file tkTextIndex.c. +# This file is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) textIndex.test 1.9 96/06/24 16:46:55 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +catch {destroy .t} +if [catch {text .t -font {Courier 12} -width 20 -height 10}] { + puts "The font needed by these tests isn't available, so I'm" + puts "going to skip the tests." + return +} +pack append . .t {top expand fill} +update +.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 . + +.t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + +test textIndex-1.1 {TkTextMakeIndex} { + .t index -1.3 +} 1.0 +test textIndex-1.2 {TkTextMakeIndex} { + .t index 0.3 +} 1.0 +test textIndex-1.3 {TkTextMakeIndex} { + .t index 1.3 +} 1.3 +test textIndex-1.4 {TkTextMakeIndex} { + .t index 3.-1 +} 3.0 +test textIndex-1.5 {TkTextMakeIndex} { + .t index 3.3 +} 3.3 +test textIndex-1.6 {TkTextMakeIndex} { + .t index 3.5 +} 3.5 +test textIndex-1.7 {TkTextMakeIndex} { + .t index 3.6 +} 3.5 +test textIndex-1.8 {TkTextMakeIndex} { + .t index 3.7 +} 3.5 +test textIndex-1.9 {TkTextMakeIndex} { + .t index 7.2 +} 7.2 +test textIndex-1.10 {TkTextMakeIndex} { + .t index 8.0 +} 8.0 +test textIndex-1.11 {TkTextMakeIndex} { + .t index 8.1 +} 8.0 +test textIndex-1.12 {TkTextMakeIndex} { + .t index 9.0 +} 8.0 + +.t tag add x 2.3 2.6 +test textIndex-2.1 {TkTextIndexToSeg} { + .t get 2.0 +} a +test textIndex-2.2 {TkTextIndexToSeg} { + .t get 2.2 +} c +test textIndex-2.3 {TkTextIndexToSeg} { + .t get 2.3 +} d +test textIndex-2.4 {TkTextIndexToSeg} { + .t get 2.6 +} g +test textIndex-2.5 {TkTextIndexToSeg} { + .t get 2.7 +} h +test textIndex-2.6 {TkTextIndexToSeg} { + .t get 2.12 +} m +test textIndex-2.7 {TkTextIndexToSeg} { + .t get 2.13 +} \n +test textIndex-2.8 {TkTextIndexToSeg} { + .t get 2.14 +} \n +.t tag delete x + +.t mark set foo 3.2 +.t tag add x 2.8 2.11 +.t tag add x 6.0 6.2 +set weirdTag "funny . +- 22.1\n\t{" +.t tag add $weirdTag 2.1 2.6 +set weirdMark "asdf \n{-+ 66.2\t" +.t mark set $weirdMark 4.0 +.t tag config y -relief raised +test textIndex-3.1 {TkTextGetIndex, weird mark names} { + list [catch {.t index $weirdMark} msg] $msg +} {0 4.0} + +test textIndex-4.1 {TkTextGetIndex, tags} { + list [catch {.t index x.first} msg] $msg +} {0 2.8} +test textIndex-4.2 {TkTextGetIndex, tags} { + list [catch {.t index x.last} msg] $msg +} {0 6.2} +test textIndex-4.3 {TkTextGetIndex, weird tags} { + list [.t index $weirdTag.first+1c] [.t index $weirdTag.last+2c] +} {2.2 2.8} +test textIndex-4.4 {TkTextGetIndex, tags} { + list [catch {.t index x.gorp} msg] $msg +} {1 {bad text index "x.gorp"}} +test textIndex-4.5 {TkTextGetIndex, tags} { + list [catch {.t index foo.last} msg] $msg +} {1 {bad text index "foo.last"}} +test textIndex-4.6 {TkTextGetIndex, tags} { + list [catch {.t index y.first} msg] $msg +} {1 {text doesn't contain any characters tagged with "y"}} +test textIndex-4.7 {TkTextGetIndex, tags} { + list [catch {.t index x.last,} msg] $msg +} {1 {bad text index "x.last,"}} +test textIndex-4.8 {TkTextGetIndex, tags} { + .t tag add z 1.0 + set result [list [.t index z.first] [.t index z.last]] + .t tag delete z + set result +} {1.0 1.1} + +test textIndex-5.1 {TkTextGetIndex, "@"} {fonts} { + .t index @12,9 +} 1.1 +test textIndex-5.2 {TkTextGetIndex, "@"} {fonts} { + .t index @-2,7 +} 1.0 +test textIndex-5.3 {TkTextGetIndex, "@"} {fonts} { + .t index @10,-7 +} 1.0 +test textIndex-5.4 {TkTextGetIndex, "@"} {fonts} { + list [catch {.t index @x} msg] $msg +} {1 {bad text index "@x"}} +test textIndex-5.5 {TkTextGetIndex, "@"} {fonts} { + list [catch {.t index @10q} msg] $msg +} {1 {bad text index "@10q"}} +test textIndex-5.6 {TkTextGetIndex, "@"} {fonts} { + list [catch {.t index @10,} msg] $msg +} {1 {bad text index "@10,"}} +test textIndex-5.7 {TkTextGetIndex, "@"} {fonts} { + list [catch {.t index @10,a} msg] $msg +} {1 {bad text index "@10,a"}} +test textIndex-5.8 {TkTextGetIndex, "@"} {fonts} { + list [catch {.t index @10,9,} msg] $msg +} {1 {bad text index "@10,9,"}} + +test textIndex-6.1 {TkTextGetIndex, numeric} { + list [catch {.t index 2.3} msg] $msg +} {0 2.3} +test textIndex-6.2 {TkTextGetIndex, numeric} { + list [catch {.t index -} msg] $msg +} {1 {bad text index "-"}} +test textIndex-6.3 {TkTextGetIndex, numeric} { + list [catch {.t index 2.end} msg] $msg +} {0 2.13} +test textIndex-6.4 {TkTextGetIndex, numeric} { + list [catch {.t index 2.x} msg] $msg +} {1 {bad text index "2.x"}} +test textIndex-6.5 {TkTextGetIndex, numeric} { + list [catch {.t index 2.3x} msg] $msg +} {1 {bad text index "2.3x"}} + +test textIndex-7.1 {TkTextGetIndex, miscellaneous other bases} { + list [catch {.t index end} msg] $msg +} {0 8.0} +test textIndex-7.2 {TkTextGetIndex, miscellaneous other bases} { + list [catch {.t index foo} msg] $msg +} {0 3.2} +test textIndex-7.3 {TkTextGetIndex, miscellaneous other bases} { + list [catch {.t index foo+1c} msg] $msg +} {0 3.3} + +test textIndex-8.1 {TkTextGetIndex, modifiers} { + list [catch {.t index 2.1+1char} msg] $msg +} {0 2.2} +test textIndex-8.2 {TkTextGetIndex, modifiers} { + list [catch {.t index "2.1 +1char"} msg] $msg +} {0 2.2} +test textIndex-8.3 {TkTextGetIndex, modifiers} { + list [catch {.t index 2.1-1char} msg] $msg +} {0 2.0} +test textIndex-8.4 {TkTextGetIndex, modifiers} { + list [catch {.t index {2.1 }} msg] $msg +} {0 2.1} +test textIndex-8.5 {TkTextGetIndex, modifiers} { + list [catch {.t index {2.1+foo bar}} msg] $msg +} {1 {bad text index "2.1+foo bar"}} +test textIndex-8.6 {TkTextGetIndex, modifiers} { + list [catch {.t index {2.1 foo bar}} msg] $msg +} {1 {bad text index "2.1 foo bar"}} + +test textIndex-9.1 {TkTextIndexCmp} { + list [.t compare 3.1 < 3.2] [.t compare 3.1 == 3.2] +} {1 0} +test textIndex-9.2 {TkTextIndexCmp} { + list [.t compare 3.2 < 3.2] [.t compare 3.2 == 3.2] +} {0 1} +test textIndex-9.3 {TkTextIndexCmp} { + list [.t compare 3.3 < 3.2] [.t compare 3.3 == 3.2] +} {0 0} +test textIndex-9.4 {TkTextIndexCmp} { + list [.t compare 2.1 < 3.2] [.t compare 2.1 == 3.2] +} {1 0} +test textIndex-9.5 {TkTextIndexCmp} { + list [.t compare 4.1 < 3.2] [.t compare 4.1 == 3.2] +} {0 0} + +test textIndex-10.1 {ForwBack} { + list [catch {.t index {2.3 + x}} msg] $msg +} {1 {bad text index "2.3 + x"}} +test textIndex-10.2 {ForwBack} { + list [catch {.t index {2.3 + 2 chars}} msg] $msg +} {0 2.5} +test textIndex-10.3 {ForwBack} { + list [catch {.t index {2.3 + 2c}} msg] $msg +} {0 2.5} +test textIndex-10.4 {ForwBack} { + list [catch {.t index {2.3 - 3ch}} msg] $msg +} {0 2.0} +test textIndex-10.5 {ForwBack} { + list [catch {.t index {2.3 + 3 lines}} msg] $msg +} {0 5.3} +test textIndex-10.6 {ForwBack} { + list [catch {.t index {2.3 -1l}} msg] $msg +} {0 1.3} +test textIndex-10.7 {ForwBack} { + list [catch {.t index {2.3 -1 gorp}} msg] $msg +} {1 {bad text index "2.3 -1 gorp"}} +test textIndex-10.8 {ForwBack} { + list [catch {.t index {2.3 - 4 lines}} msg] $msg +} {0 1.3} + +test textIndex-11.1 {TkTextIndexForwChars} { + .t index {2.3 + -7 chars} +} 1.3 +test textIndex-11.2 {TkTextIndexForwChars} { + .t index {2.3 + 5 chars} +} 2.8 +test textIndex-11.3 {TkTextIndexForwChars} { + .t index {2.3 + 10 chars} +} 2.13 +test textIndex-11.4 {TkTextIndexForwChars} { + .t index {2.3 + 11 chars} +} 3.0 +test textIndex-11.5 {TkTextIndexForwChars} { + .t index {2.3 + 55 chars} +} 7.6 +test textIndex-11.6 {TkTextIndexForwChars} { + .t index {2.3 + 56 chars} +} 8.0 +test textIndex-11.7 {TkTextIndexForwChars} { + .t index {2.3 + 57 chars} +} 8.0 + +test textIndex-12.1 {TkTextIndexBackChars} { + .t index {3.2 - -10 chars} +} 4.6 +test textIndex-12.2 {TkTextIndexBackChars} { + .t index {3.2 - 2 chars} +} 3.0 +test textIndex-12.3 {TkTextIndexBackChars} { + .t index {3.2 - 3 chars} +} 2.13 +test textIndex-12.4 {TkTextIndexBackChars} { + .t index {3.2 - 22 chars} +} 1.1 +test textIndex-12.5 {TkTextIndexBackChars} { + .t index {3.2 - 23 chars} +} 1.0 +test textIndex-12.6 {TkTextIndexBackChars} { + .t index {3.2 - 24 chars} +} 1.0 + +proc getword index { + .t get [.t index "$index wordstart"] [.t index "$index wordend"] +} +test textIndex-13.1 {StartEnd} { + list [catch {.t index {2.3 lineend}} msg] $msg +} {0 2.13} +test textIndex-13.2 {StartEnd} { + list [catch {.t index {2.3 linee}} msg] $msg +} {0 2.13} +test textIndex-13.3 {StartEnd} { + list [catch {.t index {2.3 line}} msg] $msg +} {1 {bad text index "2.3 line"}} +test textIndex-13.4 {StartEnd} { + list [catch {.t index {2.3 linestart}} msg] $msg +} {0 2.0} +test textIndex-13.5 {StartEnd} { + list [catch {.t index {2.3 lines}} msg] $msg +} {0 2.0} +test textIndex-13.6 {StartEnd} { + getword 5.3 +} { } +test textIndex-13.7 {StartEnd} { + getword 5.4 +} GIrl +test textIndex-13.8 {StartEnd} { + getword 5.7 +} GIrl +test textIndex-13.9 {StartEnd} { + getword 5.8 +} { } +test textIndex-13.10 {StartEnd} { + getword 5.14 +} x_yz +test textIndex-13.11 {StartEnd} { + getword 6.2 +} # +test textIndex-13.12 {StartEnd} { + getword 3.4 +} 12345 +.t tag add x 2.8 2.11 +test textIndex-13.13 {StartEnd} { + list [catch {.t index {2.2 worde}} msg] $msg +} {0 2.13} +test textIndex-13.14 {StartEnd} { + list [catch {.t index {2.12 words}} msg] $msg +} {0 2.0} +test textIndex-13.15 {StartEnd} { + list [catch {.t index {2.12 word}} msg] $msg +} {1 {bad text index "2.12 word"}} + +catch {destroy .t} +concat diff --git a/tests/textMark.test b/tests/textMark.test new file mode 100644 index 0000000..39a0961 --- /dev/null +++ b/tests/textMark.test @@ -0,0 +1,222 @@ +# This file is a Tcl script to test the code in the file tkTextMark.c. +# This file is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) textMark.test 1.8 97/10/20 11:13:00 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +catch {destroy .t} +if [catch {text .t -font {Courier 12} -width 20 -height 10}] { + puts "The font needed by these tests isn't available, so I'm" + puts "going to skip the tests." + return +} +pack append . .t {top expand fill} +update +.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 . + +entry .t.e +.t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + +test textMark-1.1 {TkTextMarkCmd - missing option} { + list [catch {.t mark} msg] $msg +} {1 {wrong # args: should be ".t mark option ?arg arg ...?"}} +test textMark-1.2 {TkTextMarkCmd - bogus option} { + 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} { + list [catch {.t mark gravity foo} msg] $msg +} {1 {there is no mark named "foo"}} +test textMark-1.4 {TkTextMarkCmd - "gravity" option} { + .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} { + .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} { + .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} { + 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} { + list [catch {.t mark gravity} msg] $msg +} {1 {wrong # args: should be ".t mark gravity markName ?gravity?"}} + +test textMark-2.1 {TkTextMarkCmd - "names" option} { + 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} { + lsort [.t mark n] +} {current insert} +test textMark-2.3 {TkTextMarkCmd - "names" option} { + .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} { + 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} { + 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} { + list [catch {.t mark set a @x} msg] $msg +} {1 {bad text index "@x"}} +test textMark-3.4 {TkTextMarkCmd - "set" option} { + .t mark set a 1.2 + .t index a +} 1.2 +test textMark-3.5 {TkTextMarkCmd - "set" option} { + .t mark set a end + .t index a +} {8.0} + +test textMark-4.1 {TkTextMarkCmd - "unset" option} { + list [catch {.t mark unset} msg] $msg +} {0 {}} +test textMark-4.2 {TkTextMarkCmd - "unset" option} { + .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} { + .t mark set a 1.2 + .t mark set b 2.3 + .t mark set 49ers 3.1 + eval .t mark unset [.t mark names] + lsort [.t mark names] +} {current insert} + +test textMark-5.1 {TkTextMarkCmd - miscellaneous} { + list [catch {.t mark} msg] $msg +} {1 {wrong # args: should be ".t mark option ?arg arg ...?"}} +test textMark-5.2 {TkTextMarkCmd - miscellaneous} { + 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} { + .t mark set a 1.2 + .t mark set b 1.2 + .t mark set c 1.2 + .t mark set d 1.4 + list [.t index a] [.t index b] [.t index c ] [.t index d] +} {1.2 1.2 1.2 1.4} + +catch {eval {.t mark unset} [.t mark names]} +test textMark-7.1 {MarkFindNext - invalid mark name} { + catch {.t mark next bogus} x + set x +} {bad text index "bogus"} +test textMark-7.2 {MarkFindNext - marks at same location} { + .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} { + .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} { + .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} { + .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} { + .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} { + .t mark set current end + .t mark next end +} {current} +test textMark-7.8 {MarkFindNext - no next mark} { + .t mark set current 1.0 + .t mark set insert 3.0 + .t mark next insert +} {} +test textMark-8.1 {MarkFindPrev - invalid mark name} { + catch {.t mark prev bogus} x + set x +} {bad text index "bogus"} +test textMark-8.2 {MarkFindPrev - marks at same location} { + .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} { + .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} { + .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} { + .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} { + .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} { + .t mark set insert 3.0 + .t mark set current end + .t mark prev end +} {insert} +test textMark-8.8 {MarkFindPrev - no previous mark} { + .t mark set current 1.0 + .t mark set insert 3.0 + .t mark prev current +} {} + +catch {destroy .t} +concat {} diff --git a/tests/textTag.test b/tests/textTag.test new file mode 100644 index 0000000..ae0d33a --- /dev/null +++ b/tests/textTag.test @@ -0,0 +1,756 @@ +# This file is a Tcl script to test the code in the file tkTextTag.c. +# This file is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) textTag.test 1.30 97/11/06 16:57:02 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +catch {destroy .t} +if [catch {text .t -font {Courier 12} -width 20 -height 10}] { + puts "The font needed by these tests isn't available, so I'm" + puts "going to skip the tests." + return +} +pack append . .t {top expand fill} +update +.t debug on +wm geometry . {} +set bigFont {Helvetica 24} + +# 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 . + +entry .t.e +.t.e insert 0 "Text" + +.t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + + +set i 1 +foreach test { + {-background #012345 #012345 non-existent + {unknown color name "non-existent"}} + {-bgstipple gray50 gray50 badStipple + {bitmap "badStipple" not defined}} + {-borderwidth 2 2 46q + {bad screen distance "46q"}} + {-fgstipple gray25 gray25 bogus + {bitmap "bogus" not defined}} + {-font fixed fixed {} + {font "" doesn't exist}} + {-foreground #001122 #001122 {silly color} + {unknown color name "silly color"}} + {-justify left left middle + {bad justification "middle": must be left, right, or center}} + {-lmargin1 10 10 bad + {bad screen distance "bad"}} + {-lmargin2 10 10 bad + {bad screen distance "bad"}} + {-offset 2 2 100xyz + {bad screen distance "100xyz"}} + {-overstrike on on stupid + {expected boolean value but got "stupid"}} + {-relief raised raised stupid + {bad relief type "stupid": must be flat, groove, raised, ridge, solid, or sunken}} + {-rmargin 10 10 bad + {bad screen distance "bad"}} + {-spacing1 10 10 bad + {bad screen distance "bad"}} + {-spacing2 10 10 bad + {bad screen distance "bad"}} + {-spacing3 10 10 bad + {bad screen distance "bad"}} + {-tabs {10 20 30} {10 20 30} {10 fork} + {bad tab alignment "fork": must be left, right, center, or numeric}} + {-underline no no stupid + {expected boolean value but got "stupid"}} +} { + set name [lindex $test 0] + test textTag-1.$i {tag configuration options} { + .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} { + 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} { + list [catch {.t tag} msg] $msg +} {1 {wrong # args: should be ".t tag option ?arg arg ...?"}} +test textTag-2.2 {TkTextTagCmd - "add" option} { + 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} { + 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} { + list [catch {.t tag add x gorp} msg] $msg +} {1 {bad text index "gorp"}} +test textTag-2.5 {TkTextTagCmd - "add" option} { + list [catch {.t tag add x 1.2 gorp} msg] $msg +} {1 {bad text index "gorp"}} +test textTag-2.6 {TkTextTagCmd - "add" option} { + .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} { + .t tag add x 1.0 1.end + .t tag ranges x +} {1.0 1.6} +test textTag-2.8 {TkTextTagCmd - "add" option} { + .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} { + .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} { + .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} { + .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} { + .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} { + 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} { + 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} { + .t tag bind x <Enter> script1 + .t tag bind x <Enter> +} script1 +test textTag-3.4 {TkTextTagCmd - "bind" option} { + list [catch {.t tag bind x <Gorp> script2} msg] $msg +} {1 {bad event type or keysym "Gorp"}} +test textTag-3.5 {TkTextTagCmd - "bind" option} { + .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} { + .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} { + .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-4.1 {TkTextTagCmd - "cget" option} { + 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} { + 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} { + .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} { + list [catch {.t tag cget sel bogus} msg] $msg +} {1 {unknown option "bogus"}} +test textTag-4.5 {TkTextTagCmd - "cget" option} { + .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} { + 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} { + list [catch {.t tag configure x -foo} msg] $msg +} {1 {unknown option "-foo"}} +test textTag-5.3 {TkTextTagCmd - "configure" option} { + list [catch {.t tag configure x -background red -underline} msg] $msg +} {1 {value for "-underline" missing}} +test textTag-5.4 {TkTextTagCmd - "configure" option} { + .t tag delete x + .t tag configure x -underline yes + .t tag configure x -underline +} {-underline {} {} {} yes} +test textTag-5.5 {TkTextTagCmd - "configure" option} { + .t tag delete x + .t tag configure x -overstrike on + .t tag cget x -overstrike +} {on} +test textTag-5.6 {TkTextTagCmd - "configure" option} { + list [catch {.t tag configure x -overstrike foo} msg] $msg +} {1 {expected boolean value but got "foo"}} +test textTag-5.7 {TkTextTagCmd - "configure" option} { + .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} { + .t tag delete x + .t tag configure x -justify left + .t tag configure x -justify +} {-justify {} {} {} left} +test textTag-5.9 {TkTextTagCmd - "configure" option} { + .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} { + .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} { + .t tag delete x + .t tag configure x -offset 2 + .t tag configure x -offset +} {-offset {} {} {} 2} +test textTag-5.12 {TkTextTagCmd - "configure" option} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .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} { + .t configure -selectborderwidth 2 -selectforeground blue \ + -selectbackground black + .t tag configure sel -borderwidth 4 -foreground green -background yellow + set x {} + foreach i {-selectborderwidth -selectforeground -selectbackground} { + lappend x [lindex [.t configure $i] 4] + } + set x +} {4 green yellow} +test textTag-5.22 {TkTextTagCmd - "configure" option} { + .t configure -selectborderwidth 20 + .t tag configure sel -borderwidth {} + .t cget -selectborderwidth +} {} + +test textTag-6.1 {TkTextTagCmd - "delete" option} { + list [catch {.t tag delete} msg] $msg +} {1 {wrong # args: should be ".t tag delete tagName tagName ..."}} +test textTag-6.2 {TkTextTagCmd - "delete" option} { + list [catch {.t tag delete zork} msg] $msg +} {0 {}} +test textTag-6.3 {TkTextTagCmd - "delete" option} { + .t tag delete x + .t tag config x -background black + .t tag config y -foreground white + .t tag config z -background black + .t tag delete y z + lsort [.t tag names] +} {sel x} +test textTag-6.4 {TkTextTagCmd - "delete" option} { + .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} { + .t tag bind x <Enter> foo + .t tag delete x + .t tag configure x -background black + .t tag bind x +} {} + +proc tagsetup {} { + .t tag delete x y z a b c d + .t tag remove sel 1.0 end + foreach i {a b c d} { + .t tag configure $i -background black + } +} +test textTag-7.1 {TkTextTagCmd - "lower" option} { + list [catch {.t tag lower} msg] $msg +} {1 {wrong # args: should be ".t tag lower tagName ?belowThis?"}} +test textTag-7.2 {TkTextTagCmd - "lower" option} { + list [catch {.t tag lower foo} msg] $msg +} {1 {tag "foo" isn't defined in text widget}} +test textTag-7.3 {TkTextTagCmd - "lower" option} { + 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} { + tagsetup + .t tag lower c + .t tag names +} {c sel a b d} +test textTag-7.5 {TkTextTagCmd - "lower" option} { + tagsetup + .t tag lower d b + .t tag names +} {sel a d b c} +test textTag-7.6 {TkTextTagCmd - "lower" option} { + tagsetup + .t tag lower a c + .t tag names +} {sel b a c d} + +test textTag-8.1 {TkTextTagCmd - "names" option} { + 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} { + tagsetup + .t tag names +} {sel a b c d} +test textTag-8.3 {TkTextTagCmd - "names" option} { + tagsetup + .t tag add "a b" 2.1 2.6 + .t tag add c 2.4 2.7 + .t tag names 2.5 +} {c {a b}} + +.t tag delete x y z a b c d {a b} +.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} { + 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} { + 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} { + list [catch {.t tag nextrange foo 1.0} msg] $msg +} {0 {}} +test textTag-9.4 {TkTextTagCmd - "nextrange" option} { + list [catch {.t tag nextrange x foo} msg] $msg +} {1 {bad text index "foo"}} +test textTag-9.5 {TkTextTagCmd - "nextrange" option} { + list [catch {.t tag nextrange x 1.0 bar} msg] $msg +} {1 {bad text index "bar"}} +test textTag-9.6 {TkTextTagCmd - "nextrange" option} { + .t tag nextrange x 1.0 +} {2.3 2.5} +test textTag-9.7 {TkTextTagCmd - "nextrange" option} { + .t tag nextrange x 2.2 +} {2.3 2.5} +test textTag-9.8 {TkTextTagCmd - "nextrange" option} { + .t tag nextrange x 2.3 +} {2.3 2.5} +test textTag-9.9 {TkTextTagCmd - "nextrange" option} { + .t tag nextrange x 2.4 +} {2.9 3.1} +test textTag-9.10 {TkTextTagCmd - "nextrange" option} { + .t tag nextrange x 2.4 2.9 +} {} +test textTag-9.11 {TkTextTagCmd - "nextrange" option} { + .t tag nextrange x 2.4 2.10 +} {2.9 3.1} +test textTag-9.12 {TkTextTagCmd - "nextrange" option} { + .t tag nextrange x 2.4 2.11 +} {2.9 3.1} +test textTag-9.13 {TkTextTagCmd - "nextrange" option} { + .t tag nextrange x 7.0 +} {7.2 7.3} +test textTag-9.14 {TkTextTagCmd - "nextrange" option} { + .t tag nextrange x 7.3 +} {} + +test textTag-10.1 {TkTextTagCmd - "prevrange" option} { + 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} { + 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} { + list [catch {.t tag prevrange foo end} msg] $msg +} {0 {}} +test textTag-10.4 {TkTextTagCmd - "prevrange" option} { + list [catch {.t tag prevrange x foo} msg] $msg +} {1 {bad text index "foo"}} +test textTag-10.5 {TkTextTagCmd - "prevrange" option} { + list [catch {.t tag prevrange x end bar} msg] $msg +} {1 {bad text index "bar"}} +test textTag-10.6 {TkTextTagCmd - "prevrange" option} { + .t tag prevrange x end +} {7.2 7.3} +test textTag-10.7 {TkTextTagCmd - "prevrange" option} { + .t tag prevrange x 2.4 +} {2.3 2.5} +test textTag-10.8 {TkTextTagCmd - "prevrange" option} { + .t tag prevrange x 2.5 +} {2.3 2.5} +test textTag-10.9 {TkTextTagCmd - "prevrange" option} { + .t tag prevrange x 2.9 +} {2.3 2.5} +test textTag-10.10 {TkTextTagCmd - "prevrange" option} { + .t tag prevrange x 2.9 2.6 +} {} +test textTag-10.11 {TkTextTagCmd - "prevrange" option} { + .t tag prevrange x 2.9 2.5 +} {} +test textTag-10.12 {TkTextTagCmd - "prevrange" option} { + .t tag prevrange x 2.9 2.3 +} {2.3 2.5} +test textTag-10.13 {TkTextTagCmd - "prevrange" option} { + .t tag prevrange x 7.0 +} {2.9 3.1} +test textTag-10.14 {TkTextTagCmd - "prevrange" option} { + .t tag prevrange x 2.3 +} {} + +test textTag-11.1 {TkTextTagCmd - "raise" option} { + list [catch {.t tag raise} msg] $msg +} {1 {wrong # args: should be ".t tag raise tagName ?aboveThis?"}} +test textTag-11.2 {TkTextTagCmd - "raise" option} { + list [catch {.t tag raise foo} msg] $msg +} {1 {tag "foo" isn't defined in text widget}} +test textTag-11.3 {TkTextTagCmd - "raise" option} { + 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} { + tagsetup + .t tag raise c + .t tag names +} {sel a b d c} +test textTag-11.5 {TkTextTagCmd - "raise" option} { + tagsetup + .t tag raise d b + .t tag names +} {sel a b d c} +test textTag-11.6 {TkTextTagCmd - "raise" option} { + tagsetup + .t tag raise a c + .t tag names +} {sel b c a d} + +test textTag-12.1 {TkTextTagCmd - "ranges" option} { + list [catch {.t tag ranges} msg] $msg +} {1 {wrong # args: should be ".t tag ranges tagName"}} +test textTag-12.2 {TkTextTagCmd - "ranges" option} { + .t tag delete x + .t tag ranges x +} {} +test textTag-12.3 {TkTextTagCmd - "ranges" option} { + .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} { + .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} { + 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} { + .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} { + .t configure -exportselection 1 + .t tag remove sel 1.0 end + .t tag add sel 2.4 3.3 + .t.e select to 4 + .t tag remove sel 2.7 3.1 + selection get +} Text + +.t tag delete x a b c d +test textTag-14.1 {SortTags} { + 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} { + foreach i {a b c d} { + .t tag configure $i -background black + } + foreach i {d c b a} { + .t tag add $i 2.0 2.2 + } + .t tag names 2.1 +} {a b c d} +.t tag delete x a b c d +test textTag-14.3 {SortTags} { + 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} { + for {set i 0} {$i < 30} {incr i} { + .t tag configure x$i -background black + } + for {set i 29} {$i >= 0} {incr i -1} { + .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} + +foreach tag [.t tag names] { + catch {.t tag delete $tag} +} +set c [.t bbox 2.1] +set x1 [expr [lindex $c 0] + [lindex $c 2]/2] +set y1 [expr [lindex $c 1] + [lindex $c 3]/2] +set c [.t bbox 3.2] +set x2 [expr [lindex $c 0] + [lindex $c 2]/2] +set y2 [expr [lindex $c 1] + [lindex $c 3]/2] +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} { + bind .t <ButtonRelease> {lappend x up} + .t tag bind x <ButtonRelease> {lappend x x-up} + .t tag bind y <ButtonRelease> {lappend x y-up} + set x {} + .t tag add x 2.0 2.4 + .t tag add y 4.3 + event gen .t <Motion> -x $x1 -y $y1 + event gen .t <ButtonRelease> -x $x1 -y $y1 + event gen .t <Motion> -x $x2 -y $y2 + event gen .t <ButtonRelease> -x $x2 -y $y2 + event gen .t <Motion> -x $x3 -y $y3 + event gen .t <ButtonRelease> -x $x3 -y $y3 + bind .t <ButtonRelease> {} + set x +} {x-up up up y-up up} +test textTag-15.2 {TkTextBindProc} { + catch {.t tag delete x} + catch {.t tag delete y} + .t tag bind x <Enter> {lappend x x-enter} + .t tag bind x <ButtonPress> {lappend x x-down} + .t tag bind x <ButtonRelease> {lappend x x-up} + .t tag bind x <Leave> {lappend x x-leave} + .t tag bind y <Enter> {lappend x y-enter} + .t tag bind y <ButtonPress> {lappend x y-down} + .t tag bind y <ButtonRelease> {lappend x y-up} + .t tag bind y <Leave> {lappend x y-leave} + event gen .t <Motion> -x 0 -y 0 + set x {} + .t tag add x 2.0 2.4 + .t tag add y 4.3 + event gen .t <Motion> -x $x1 -y $y1 + lappend x | + event gen .t <Button> -x $x1 -y $y1 + lappend x | + event gen .t <Motion> -x $x3 -y $y3 -state 0x100 + lappend x | + 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} { + catch {.t tag delete x} + catch {.t tag delete y} + .t tag bind x <Enter> {lappend x x-enter} + .t tag bind x <Any-ButtonPress-1> {lappend x x-down} + .t tag bind x <Any-ButtonRelease-1> {lappend x x-up} + .t tag bind x <Leave> {lappend x x-leave} + .t tag bind y <Enter> {lappend x y-enter} + .t tag bind y <Any-ButtonPress-1> {lappend x y-down} + .t tag bind y <Any-ButtonRelease-1> {lappend x y-up} + .t tag bind y <Leave> {lappend x y-leave} + event gen .t <Motion> -x 0 -y 0 + set x {} + .t tag add x 2.0 2.4 + .t tag add y 4.3 + event gen .t <Motion> -x $x1 -y $y1 + lappend x | + event gen .t <Button-1> -x $x1 -y $y1 + lappend x | + event gen .t <Button-2> -x $x1 -y $y1 -state 0x100 + lappend x | + event gen .t <Motion> -x $x3 -y $y3 -state 0x300 + lappend x | + event gen .t <ButtonRelease-1> -x $x3 -y $y3 -state 0x300 + lappend x | + event gen .t <ButtonRelease-2> -x $x3 -y $y3 -state 0x200 + set x +} {x-enter | x-down | | | x-up | x-leave y-enter} + +foreach tag [.t tag names] { + catch {.t tag delete $tag} +} +.t tag configure big -font $bigFont +test textTag-16.1 {TkTextPickCurrent procedure} { + event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1 + set x [.t index current] + event gen .t <Motion> -x $x2 -y $y2 + lappend x [.t index current] + event gen .t <Button-1> -x $x2 -y $y2 + lappend x [.t index current] + event gen .t <Motion> -x $x3 -y $y3 -state 0x100 + lappend x [.t index current] + event gen .t <Button-3> -state 0x100 -x $x3 -y $y3 + lappend x [.t index current] + event gen .t <ButtonRelease-3> -state 0x300 -x $x3 -y $y3 + lappend x [.t index current] + 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} { + event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1 + event gen .t <Motion> -x $x2 -y $y2 + set x [.t index current] + .t tag add big 3.0 + update + lappend x [.t index current] +} {3.2 3.1} +.t tag remove big 1.0 end +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} { + foreach i {a b c d} { + .t tag remove $i 1.0 end + } + .t tag lower b + .t tag lower a + set x {} + event gen .t <Motion> -x $x1 -y $y1 + .t tag add a 2.1 3.3 + .t tag add b 2.1 + .t tag add c 3.2 + update + lappend x | + event gen .t <Motion> -x $x2 -y $y2 + lappend x | + 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} { + foreach i {a b c d} { + .t tag remove $i 1.0 end + } + .t tag lower b + .t tag lower a + set x {} + event gen .t <Motion> -x $x1 -y $y1 + .t tag add a 2.1 3.3 + .t tag add b 2.1 + .t tag add c 2.1 + update + lappend x | + .t tag lower c + event gen .t <Motion> -x $x2 -y $y2 + set x +} {enter-a enter-b enter-c | leave-c leave-b} +foreach i {a b c d} { + .t tag delete $i +} +test textTag-16.5 {TkTextPickCurrent procedure} { + foreach i {a b c d} { + .t tag remove $i 1.0 end + } + event gen .t <Motion> -x $x1 -y $y1 + .t tag bind a <Enter> {.t tag add big 3.0 3.2} + .t tag add a 3.2 + event gen .t <Motion> -x $x2 -y $y2 + .t index current +} {3.2} +test textTag-16.6 {TkTextPickCurrent procedure} { + foreach i {a b c d} { + .t tag remove $i 1.0 end + } + event gen .t <Motion> -x $x1 -y $y1 + .t tag bind a <Enter> {.t tag add big 3.0 3.2} + .t tag add a 3.2 + event gen .t <Motion> -x $x2 -y $y2 + update + .t index current +} {3.1} +test textTag-16.7 {TkTextPickCurrent procedure} { + foreach i {a b c d} { + .t tag remove $i 1.0 end + } + event gen .t <Motion> -x $x1 -y $y1 + .t tag bind a <Leave> {.t tag add big 3.0 3.2} + .t tag add a 2.1 + event gen .t <Motion> -x $x2 -y $y2 + .t index current +} {3.1} + +catch {destroy .t} +concat {} diff --git a/tests/textWind.test b/tests/textWind.test new file mode 100644 index 0000000..c639dab --- /dev/null +++ b/tests/textWind.test @@ -0,0 +1,826 @@ +# This file is a Tcl script to test the code in the file tkTextWind.c. +# This file is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) textWind.test 1.25 97/07/01 18:16:38 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +foreach i [winfo child .] { + catch {destroy $i} +} + + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Text.borderWidth 2 +option add *Text.highlightThickness 2 +if {$tcl_platform(platform) == "windows"} { + option add *Text.font {Courier -14} +} else { + option add *Text.font {Courier -12} +} + +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 +} + +# 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 . + +test textWind-1.1 {basic tests of options} {fonts} { + .t delete 1.0 end + .t insert end "This is the first line" + .t insert end "\nAnd this is a second line, which wraps around" + frame .f -width 3 -height 3 -bg $color + .t window create 2.2 -window .f + update + list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \ + [.t window configure .f -window] +} {1 3x3+19+23 {19 23 3 3} {-window {} {} {} .f}} +test textWind-1.2 {basic tests of options} {fonts} { + .t delete 1.0 end + .t insert end "This is the first line" + .t insert end "\nAnd this is a second line, which wraps around" + frame .f -width 3 -height 3 -bg $color + .t window create 2.2 -window .f -align top + update + list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \ + [.t window configure .f -align] +} {1 3x3+19+18 {19 18 3 3} {-align {} {} center top}} +test textWind-1.3 {basic tests of options} { + .t delete 1.0 end + .t insert end "This is the first line" + .t insert end "\nAnd this is a second line, which wraps around" + .t window create 2.2 -create "Test script" + .t window configure 2.2 -create +} {-create {} {} {} {Test script}} +test textWind-1.4 {basic tests of options} {fonts} { + .t delete 1.0 end + .t insert end "This is the first line" + .t insert end "\nAnd this is a second line, which wraps around" + frame .f -width 10 -height 20 -bg $color + .t window create 2.2 -window .f -padx 5 + update + list [winfo geom .f] [.t window configure .f -padx] [.t bbox 2.3] +} {10x20+24+18 {-padx {} {} 0 5} {39 21 7 13}} +test textWind-1.5 {basic tests of options} {fonts} { + .t delete 1.0 end + .t insert end "This is the first line" + .t insert end "\nAnd this is a second line, which wraps around" + frame .f -width 10 -height 20 -bg $color + .t window create 2.2 -window .f -pady 4 + update + list [winfo geom .f] [.t window configure .f -pady] [.t bbox 2.31] +} {10x20+19+22 {-pady {} {} 0 4} {19 46 7 13}} +test textWind-1.6 {basic tests of options} {fonts} { + .t delete 1.0 end + .t insert end "This is the first line" + .t insert end "\nAnd this is a second line, which wraps around" + frame .f -width 5 -height 5 -bg $color + .t window create 2.2 -window .f -stretch 1 + update + list [winfo geom .f] [.t window configure .f -stretch] +} {5x13+19+18 {-stretch {} {} 0 1}} + +.t delete 1.0 end +.t insert end "This is the first line" +frame .f -width 10 -height 6 -bg $color +.t window create 1.3 -window .f -padx 1 -pady 2 +test textWind-2.1 {TkTextWindowCmd procedure} { + list [catch {.t window} msg] $msg +} {1 {wrong # args: should be ".t window option ?arg arg ...?"}} +test textWind-2.2 {TkTextWindowCmd procedure, "cget" option} { + list [catch {.t window cget} msg] $msg +} {1 {wrong # args: should be ".t window cget index option"}} +test textWind-2.3 {TkTextWindowCmd procedure, "cget" option} { + list [catch {.t window cget a b c} msg] $msg +} {1 {wrong # args: should be ".t window cget index option"}} +test textWind-2.4 {TkTextWindowCmd procedure, "cget" option} { + list [catch {.t window cget gorp -padx} msg] $msg +} {1 {bad text index "gorp"}} +test textWind-2.5 {TkTextWindowCmd procedure, "cget" option} { + list [catch {.t window cget 1.2 -padx} msg] $msg +} {1 {no embedded window at index "1.2"}} +test textWind-2.6 {TkTextWindowCmd procedure, "cget" option} { + list [catch {.t window cget .f -bogus} msg] $msg +} {1 {unknown option "-bogus"}} +test textWind-2.7 {TkTextWindowCmd procedure, "cget" option} { + list [catch {.t window cget .f -pady} msg] $msg +} {0 2} +test textWind-2.8 {TkTextWindowCmd procedure} { + list [catch {.t window co} msg] $msg +} {1 {wrong # args: should be ".t window configure index ?option value ...?"}} +test textWind-2.9 {TkTextWindowCmd procedure} { + list [catch {.t window configure gorp} msg] $msg +} {1 {bad text index "gorp"}} +test textWind-2.10 {TkTextWindowCmd procedure} { + .t delete 1.0 end + list [catch {.t window configure 1.0} msg] $msg +} {1 {no embedded window at index "1.0"}} +test textWind-2.11 {TkTextWindowCmd procedure} { + .t delete 1.0 end + .t insert end "This is the first line" + .t insert end "\nAnd this is a second line, which wraps around" + frame .f -width 10 -height 6 -bg $color + .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo + update + list [catch {.t window configure .f} msg] $msg +} {0 {{-align {} {} center baseline} {-create {} {} {} foo} {-padx {} {} 0 1} {-pady {} {} 0 2} {-stretch {} {} 0 0} {-window {} {} {} .f}}} +test textWind-2.12 {TkTextWindowCmd procedure} { + .t delete 1.0 end + .t insert end "This is the first line" + .t insert end "\nAnd this is a second line, which wraps around" + frame .f -width 10 -height 6 -bg $color + .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo + update + list [.t window configure .f -padx 33] [.t window configure .f -padx] +} {{} {-padx {} {} 0 33}} +test textWind-2.13 {TkTextWindowCmd procedure} { + .t delete 1.0 end + .t insert end "This is the first line" + .t insert end "\nAnd this is a second line, which wraps around" + frame .f -width 10 -height 6 -bg $color + .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 + update + list [.t window configure .f -padx 14 -pady 15] \ + [.t window configure .f -padx] [.t window configure .f -pady] +} {{} {-padx {} {} 0 14} {-pady {} {} 0 15}} +test textWind-2.14 {TkTextWindowCmd procedure} { + list [catch {.t window create} msg] $msg +} {1 {wrong # args: should be ".t window create index ?option value ...?"}} +test textWind-2.15 {TkTextWindowCmd procedure} { + list [catch {.t window create gorp} msg] $msg +} {1 {bad text index "gorp"}} +test textWind-2.16 {TkTextWindowCmd procedure, don't insert after end} { + .t delete 1.0 end + .t insert end "Line 1\nLine 2" + frame .f -width 20 -height 10 -bg $color + .t window create end -window .f + .t index .f +} {2.6} +test textWind-2.17 {TkTextWindowCmd procedure} { + .t delete 1.0 end + list [catch {.t window create 1.0} msg] $msg [.t window configure 1.0] +} {0 {} {{-align {} {} center center} {-create {} {} {} {}} {-padx {} {} 0 0} {-pady {} {} 0 0} {-stretch {} {} 0 0} {-window {} {} {} {}}}} +test textWind-2.18 {TkTextWindowCmd procedure} { + .t delete 1.0 end + frame .f -width 10 -height 6 -bg $color + list [catch {.t window create 1.0 -window .f -gorp stupid} msg] $msg \ + [winfo exists .f] [.t index 1.end] [catch {.t index .f}] +} {1 {unknown option "-gorp"} 0 1.0 1} +test textWind-2.19 {TkTextWindowCmd procedure} { + .t delete 1.0 end + 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}} +destroy .f +test textWind-2.21 {TkTextWindowCmd procedure, "names" option} { + list [catch {.t window names foo} msg] $msg +} {1 {wrong # args: should be ".t window names"}} +test textWind-2.22 {TkTextWindowCmd procedure, "names" option} { + .t delete 1.0 end + .t window names +} {} +test textWind-2.23 {TkTextWindowCmd procedure, "names" option} { + .t delete 1.0 end + foreach i {.f .f2 .t.f .t.f2} { + frame $i -width 20 -height 20 + .t window create end -window $i + } + set result [.t window names] + destroy .f .f2 .t.f .t.f2 + lsort $result +} {.f .f2 .t.f .t.f2} + +test textWind-3.1 {EmbWinConfigure procedure} { + .t delete 1.0 end + frame .f -width 10 -height 6 -bg $color + .t window create 1.0 -window .f + list [catch {.t window configure 1.0 -foo bar} msg] $msg +} {1 {unknown option "-foo"}} +test textWind-3.2 {EmbWinConfigure procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.3 -window .f + update + .t window configure 1.3 -window {} + update + list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4] +} {1 {bad text index ".f"} 0 {26 5 7 13}} +catch {destroy .f} +test textWind-3.3 {EmbWinConfigure procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .t.f -width 10 -height 20 -bg $color + .t window create 1.3 -window .t.f + update + .t window configure 1.3 -window {} + update + list [catch {.t index .t.f} msg] $msg [winfo ismapped .t.f] [.t bbox 1.4] +} {1 {bad text index ".t.f"} 0 {26 5 7 13}} +catch {destroy .t.f} +test textWind-3.4 {EmbWinConfigure procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.3 + update + .t window configure 1.3 -window .f + update + list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4] +} {0 1.3 1 {36 8 7 13}} +test textWind-3.5 {EmbWinConfigure procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f + frame .f.f -width 15 -height 20 -bg $color + pack .f.f + list [catch {.t window create 1.3 -window .f.f} msg] $msg +} {1 {can't embed .f.f in .t}} +catch {destroy .f} +test textWind-3.6 {EmbWinConfigure procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + toplevel .t2 -width 20 -height 10 -bg $color + .t window create 1.3 + list [catch {.t window configure 1.3 -window .t2} msg] $msg \ + [.t window configure 1.3 -window] +} {1 {can't embed .t2 in .t} {-window {} {} {} {}}} +catch {destroy .t2} +test textWind-3.7 {EmbWinConfigure procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + .t window create 1.3 + list [catch {.t window configure 1.3 -window .t} msg] $msg +} {1 {can't embed .t in .t}} +test textWind-3.8 {EmbWinConfigure procedure} { + # This test checks for various errors when the text claims + # a window away from itself. + .t delete 1.0 end + .t insert 1.0 "Some sample text" + button .t.b -text "Hello!" + .t window create 1.4 -window .t.b + .t window create 1.6 -window .t.b + update + .t index .t.b +} {1.6} + +.t delete 1.0 end +frame .f -width 10 -height 20 -bg $color +.t window create 1.0 -window .f +test textWind-4.1 {AlignParseProc and AlignPrintProc procedures} { + .t window configure 1.0 -align baseline + .t window configure 1.0 -align +} {-align {} {} center baseline} +test textWind-4.2 {AlignParseProc and AlignPrintProc procedures} { + .t window configure 1.0 -align bottom + .t window configure 1.0 -align +} {-align {} {} center bottom} +test textWind-4.3 {AlignParseProc and AlignPrintProc procedures} { + .t window configure 1.0 -align center + .t window configure 1.0 -align +} {-align {} {} center center} +test textWind-4.4 {AlignParseProc and AlignPrintProc procedures} { + .t window configure 1.0 -align top + .t window configure 1.0 -align +} {-align {} {} center top} +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}} + +test textWind-5.1 {EmbWinStructureProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -window .f + update + destroy .f + list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3] +} {1 {bad text index ".f"} {19 11 0 0} {19 5 7 13}} +test textWind-5.2 {EmbWinStructureProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -align bottom + .t window configure 1.2 -window .f + update + destroy .f + list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3] +} {1 {bad text index ".f"} {19 18 0 0} {19 5 7 13}} +test textWind-5.3 {EmbWinStructureProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + .t window create 1.2 -create {frame .f -width 10 -height 20 -bg $color} + update + .t window configure 1.2 -create {frame .f -width 20 -height 10 -bg $color} + destroy .f + update + list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3] +} {0 1.2 {19 6 20 10} {39 5 7 13}} + +test textWind-6.1 {EmbWinRequestProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -window .f + set result {} + lappend result [.t bbox 1.2] [.t bbox 1.3] + .f configure -width 25 -height 30 + 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} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -window .f + update + 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} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .t.f -width 10 -height 20 -bg $color + .t window create 1.2 -window .t.f + update + place .t.f -x 100 -y 50 + update + list [winfo geom .t.f] [.t bbox 1.2] +} {10x20+104+54 {19 11 0 0}} +catch {destroy .f} +catch {destroy .t.f} + +test textWind-8.1 {EmbWinDeleteProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -window .f + bind .f <Destroy> {set x destroyed} + set x XXX + .t delete 1.2 + list $x [.t bbox 1.2] [.t bbox 1.3] [catch {.t index .f} msg] $msg \ + [winfo exists .f] +} {destroyed {19 5 7 13} {26 5 7 13} 1 {bad text index ".f"} 0} + +test textWind-9.1 {EmbWinCleanupProc procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text\nA second line." + frame .f -width 10 -height 20 -bg $color + .t window create 2.3 -window .f + .t delete 1.5 2.1 + .t index .f +} 1.7 + +proc bgerror args { + global msg + set msg $args +} + +test textWind-10.1 {EmbWinLayoutProc procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + .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} +test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + .t window create 1.5 -create { + error "couldn't create window" + } + set msg xyzzy + update + list $msg [.t bbox 1.5] +} {{{couldn't create window}} {40 11 0 0}} +test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + .t window create 1.5 -create { + concat gorp + } + set msg xyzzy + 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} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + .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} +catch {destroy .t.f} +test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + .t window create 1.5 -create { + concat .t + } + set msg xyzzy + 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} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + .t window create 1.5 -create { + toplevel .t2 -width 100 -height 150 + wm geom .t2 +0+0 + concat .t2 + } + set msg xyzzy + update + list $msg [.t bbox 1.5] +} {{{can't embed .t2 relative to .t}} {40 11 0 0}} +test textWind-10.7 {EmbWinLayoutProc procedure, steal window from self} { + .t delete 1.0 end + .t insert 1.0 ABCDEFGHIJKLMNOP + button .t.b -text "Hello!" + .t window create 1.5 -window .t.b + update + .t window create 1.3 -create {concat .t.b} + update + .t index .t.b +} {1.3} +catch {destroy .t2} +test textWind-10.8 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 125 -height 20 -bg $color -bd 2 -relief raised + .t window create 1.12 -window .f + list [.t bbox .f] [.t bbox 1.13] +} {{89 5 126 20} {5 25 7 13}} +test textWind-10.9 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 126 -height 20 -bg $color -bd 2 -relief raised + .t window create 1.12 -window .f + update + list [.t bbox .f] [.t bbox 1.13] +} {{89 5 126 20} {5 25 7 13}} +test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 127 -height 20 -bg $color -bd 2 -relief raised + .t window create 1.12 -window .f + update + list [.t bbox .f] [.t bbox 1.13] +} {{5 18 127 20} {132 21 7 13}} +test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} { + .t configure -wrap none + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 130 -height 20 -bg $color -bd 2 -relief raised + .t window create 1.12 -window .f + update + list [.t bbox .f] [.t bbox 1.13] +} {{89 5 126 20} {}} +test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { + .t configure -wrap none + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 130 -height 220 -bg $color -bd 2 -relief raised + .t window create 1.12 -window .f + update + list [.t bbox .f] [.t bbox 1.13] +} {{89 5 126 78} {}} +test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { + .t configure -wrap char + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 250 -height 220 -bg $color -bd 2 -relief raised + .t window create 1.12 -window .f + update + list [.t bbox .f] [.t bbox 1.13] +} {{5 18 210 65} {}} + +test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + pack forget .t + place .t -x 30 -y 50 + frame .f -width 30 -height 20 -bg $color + .t window create 1.12 -window .f + update + winfo geom .f +} {30x20+119+55} +place forget .t +pack .t +test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + pack forget .t + place .t -x 30 -y 50 + frame .t.f -width 30 -height 20 -bg $color + .t window create 1.12 -window .t.f + update + winfo geom .t.f +} {30x20+89+5} +place forget .t +pack .t +test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 30 -height 20 -bg $color + .t window create 1.12 -window .f + update + bind .f <Configure> {set x ".f configured"} + set x {no configures} + .t delete 1.0 + .t insert 1.0 "X" + update + set x +} {no configures} +test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { + .t delete 1.0 end + .t insert 1.0 "xyzzy\nFirst window here: " + .t configure -wrap none + frame .f -width 30 -height 20 -bg $color + .t window create end -window .f + .t insert end " and second here: " + frame .f2 -width 40 -height 10 -bg $color + .t window create end -window .f2 + .t insert end " with junk after it." + .t xview moveto 0 + .t xview scroll 5 units + update + list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] [winfo ismapped .f2] +} {1 30x20+103+18 {103 18 30 20} 0} +test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { + .t delete 1.0 end + .t insert 1.0 "xyzzy\nFirst window here: " + .t configure -wrap none + frame .f -width 30 -height 20 -bg $color + .t window create end -window .f + .t insert end " and second here: " + frame .f2 -width 40 -height 10 -bg $color + .t window create end -window .f2 + .t insert end " with junk after it." + update + .t xview moveto 0 + .t xview scroll 25 units + update + list [winfo ismapped .f] [winfo ismapped .f2] [winfo geom .f2] [.t bbox .f2] +} {0 1 40x10+119+23 {119 23 40 10}} +.t configure -wrap char + +test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 30 -height 20 -bg $color + .t window create 1.2 -window .f + bind .f <Map> {lappend x mapped} + bind .f <Unmap> {lappend x unmapped} + set x created + update + lappend x modified + .t delete 1.0 + update + lappend x replaced + .t window configure .f -window {} + .t delete 1.1 + .t window create 1.4 -window .f + update + lappend x off-screen + .t configure -wrap none + .t insert 1.0 "Enough text to make the line run off-screen" + update + set x +} {created mapped modified replaced unmapped mapped off-screen unmapped} + +test textWind-13.1 {EmbWinBboxProc procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 5 -height 5 -bg $color + .t window create 1.2 -window .f -align top -padx 2 -pady 1 + update + list [winfo geom .f] [.t bbox .f] +} {5x5+21+6 {21 6 5 5}} +test textWind-13.2 {EmbWinBboxProc procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 5 -height 5 -bg $color + .t window create 1.2 -window .f -align center -padx 2 -pady 1 + update + list [winfo geom .f] [.t bbox .f] +} {5x5+21+9 {21 9 5 5}} +test textWind-13.3 {EmbWinBboxProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 5 -height 5 -bg $color + .t window create 1.2 -window .f -align baseline -padx 2 -pady 1 + update + list [winfo geom .f] [.t bbox .f] +} {5x5+21+10 {21 10 5 5}} +test textWind-13.4 {EmbWinBboxProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 5 -height 5 -bg $color + .t window create 1.2 -window .f -align bottom -padx 2 -pady 1 + update + list [winfo geom .f] [.t bbox .f] +} {5x5+21+12 {21 12 5 5}} +test textWind-13.5 {EmbWinBboxProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 5 -height 5 -bg $color + .t window create 1.2 -window .f -align top -padx 2 -pady 1 -stretch 1 + update + list [winfo geom .f] [.t bbox .f] +} {5x11+21+6 {21 6 5 11}} +test textWind-13.6 {EmbWinBboxProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 5 -height 5 -bg $color + .t window create 1.2 -window .f -align center -padx 2 -pady 1 -stretch 1 + update + list [winfo geom .f] [.t bbox .f] +} {5x11+21+6 {21 6 5 11}} +test textWind-13.7 {EmbWinBboxProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 5 -height 5 -bg $color + .t window create 1.2 -window .f -align baseline -padx 2 -pady 1 -stretch 1 + update + list [winfo geom .f] [.t bbox .f] +} {5x9+21+6 {21 6 5 9}} +test textWind-13.8 {EmbWinBboxProc procedure} {fonts} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 5 -height 5 -bg $color + .t window create 1.2 -window .f -align bottom -padx 2 -pady 1 -stretch 1 + update + list [winfo geom .f] [.t bbox .f] +} {5x11+21+6 {21 6 5 11}} +test textWind-13.9 {EmbWinBboxProc procedure, spacing options} { + .t configure -spacing1 5 -spacing3 2 + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 5 -height 5 -bg $color + .t window create 1.2 -window .f -align center -padx 2 -pady 1 + update + list [winfo geom .f] [.t bbox .f] +} {5x5+21+14 {21 14 5 5}} +.t configure -spacing1 0 -spacing2 0 -spacing3 0 + +test textWind-14.1 {EmbWinDelayedUnmap procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 30 -height 20 -bg $color + .t window create 1.2 -window .f + update + bind .f <Unmap> {lappend x unmapped} + set x modified + .t insert 1.0 x + lappend x removed + .t window configure .f -window {} + lappend x updated + update + set x +} {modified removed unmapped updated} +catch {destroy .f} +test textWind-14.2 {EmbWinDelayedUnmap procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 30 -height 20 -bg $color + .t window create 1.2 -window .f + update + bind .f <Unmap> {lappend x unmapped} + set x modified + .t insert 1.0 x + lappend x deleted + .t delete .f + lappend x updated + update + set x +} {modified deleted updated} +test textWind-14.3 {EmbWinDelayedUnmap procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9" + frame .f -width 30 -height 20 -bg $color + .t window create 1.2 -window .f + update + .t yview 2.0 + set result [winfo ismapped .f] + update + list $result [winfo ismapped .f] +} {1 0} +test textWind-14.4 {EmbWinDelayedUnmap procedure} { + .t delete 1.0 end + .t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9" + frame .t.f -width 30 -height 20 -bg $color + .t window create 1.2 -window .t.f + update + .t yview 2.0 + set result [winfo ismapped .t.f] + update + list $result [winfo ismapped .t.f] +} {1 0} +catch {destroy .t.f} +catch {destroy .f} + +test textWind-15.1 {TkTextWindowIndex procedure} { + list [catch {.t index .foo} msg] $msg +} {1 {bad text index ".foo"}} +test textWind-15.2 {TkTextWindowIndex procedure} {fonts} { + .t configure -wrap none + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 30 -height 20 -bg $color + .t window create 1.6 -window .f + .t tag add a 1.1 + .t tag add a 1.3 + list [.t index .f] [.t bbox 1.7] +} {1.6 {77 8 7 13}} + +test textWind-16.1 {EmbWinTextStructureProc procedure} { + .t configure -wrap none + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 30 -height 20 -bg $color + .t window create 1.6 -window .f + update + pack forget .t + update + winfo ismapped .f +} 0 +pack .t +test textWind-16.2 {EmbWinTextStructureProc procedure} { + .t configure -wrap none + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .f -width 30 -height 20 -bg $color + .t window create 1.6 -window .f + update + set result {} + lappend result [winfo geom .f] [.t bbox .f] + frame .f2 -width 150 -height 30 -bd 2 -relief raised + pack .f2 -before .t + update + lappend result [winfo geom .f] [.t bbox .f] +} {30x20+47+5 {47 5 30 20} 30x20+47+35 {47 5 30 20}} +catch {destroy .f2} +test textWind-16.3 {EmbWinTextStructureProc procedure} { + .t configure -wrap none + .t delete 1.0 end + .t insert 1.0 "Some sample text" + .t window create 1.6 + update + pack forget .t + update +} {} +pack .t +test textWind-16.4 {EmbWinTextStructureProc procedure} { + .t configure -wrap none + .t delete 1.0 end + .t insert 1.0 "Some sample text" + frame .t.f -width 30 -height 20 -bg $color + .t window create 1.6 -window .t.f + update + pack forget .t + update + list [winfo ismapped .t.f] [.t bbox .t.f] +} {1 {47 5 30 20}} +pack .t + +catch {destroy .t} +option clear diff --git a/tests/tk.test b/tests/tk.test new file mode 100644 index 0000000..94cec66 --- /dev/null +++ b/tests/tk.test @@ -0,0 +1,80 @@ +# This file is a Tcl script to test the tk command. +# It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) tk.test 1.3 97/05/20 15:17:44 + +if {[info commands test] == ""} { + source defs +} + +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, or scaling}} + +set appname [tk appname] +test tk-2.1 {tk command: appname} { + list [catch {tk appname xyz abc} msg] $msg +} {1 {wrong # args: should be "tk appname ?newName?"}} +test tk-2.2 {tk command: appname} { + tk appname foobazgarply +} {foobazgarply} +test tk-2.3 {tk command: appname} {unixOnly} { + tk appname bazfoogarply + expr {[lsearch -exact [winfo interps] [tk appname]] >= 0} +} {1} +test tk-2.4 {tk command: appname} { + tk appname $appname +} $appname +tk appname $appname + +set scaling [tk scaling] +test tk-3.1 {tk command: scaling} { + list [catch {tk scaling -displayof} msg] $msg +} {1 {value for "-displayof" missing}} +test tk-3.2 {tk command: scaling: get current} { + tk scaling 1 + format %.2g [tk scaling] +} 1 +test tk-3.3 {tk command: scaling: get current} { + tk scaling -displayof . 1.25 + format %.3g [tk scaling] +} 1.25 +test tk-3.4 {tk command: scaling: set new} { + list [catch {tk scaling xyz} msg] $msg +} {1 {expected floating-point number but got "xyz"}} +test tk-3.5 {tk command: scaling: set new} { + list [catch {tk scaling -displayof . xyz} msg] $msg +} {1 {expected floating-point number but got "xyz"}} +test tk-3.6 {tk command: scaling: set new} { + tk scaling 1 + format %.2g [tk scaling] +} 1 +test tk-3.7 {tk command: scaling: set new} { + tk scaling -displayof . 1.25 + format %.3g [tk scaling] +} 1.25 +test tk-3.8 {tk command: scaling: negative} { + tk scaling -1 + expr {[tk scaling] > 0} +} {1} +test tk-3.9 {tk command: scaling: too big} { + tk scaling 1000000 + expr {[tk scaling] < 10000} +} {1} +test tk-3.10 {tk command: scaling: widthmm} { + tk scaling 1.25 + expr {int((25.4*[winfo screenwidth .])/(72*1.25)+0.5)-[winfo screenmmwidth .]} +} {0} +test tk-3.11 {tk command: scaling: heightmm} { + tk scaling 1.25 + expr {int((25.4*[winfo screenheight .])/(72*1.25)+0.5)-[winfo screenmmheight .]} +} {0} +tk scaling $scaling diff --git a/tests/unixButton.test b/tests/unixButton.test new file mode 100644 index 0000000..a4c67d5 --- /dev/null +++ b/tests/unixButton.test @@ -0,0 +1,182 @@ +# This file is a Tcl script to test the Unix specific behavior of +# labels, buttons, checkbuttons, and radiobuttons in Tk (i.e., all the +# widgets defined in tkUnixButton.c). It is organized in the standard +# fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixButton.test 1.6 97/07/01 18:11:30 + +if {$tcl_platform(platform)!="unix"} { + return +} + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\"" + puts "image, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Label.borderWidth 2 +option add *Label.highlightThickness 0 +option add *Label.font {Helvetica -12 bold} +option add *Button.borderWidth 2 +option add *Button.highlightThickness 2 +option add *Button.font {Helvetica -12 bold} +option add *Checkbutton.borderWidth 2 +option add *Checkbutton.highlightThickness 2 +option add *Checkbutton.font {Helvetica -12 bold} +option add *Radiobutton.borderWidth 2 +option add *Radiobutton.highlightThickness 2 +option add *Radiobutton.font {Helvetica -12 bold} + + +proc bogusTrace args { + error "trace aborted" +} +catch {unset value} +catch {unset value2} + +eval image delete [image names] +image create test image1 +label .l -text Label +button .b -text Button +checkbutton .c -text Checkbutton +radiobutton .r -text Radiobutton +pack .l .b .c .r +update + +test unixbutton-1.1 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + 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 + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {68 48 74 54 112 52 112 52} +test unixbutton-1.2 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + 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 + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {23 33 29 39 54 37 54 37} +test unixbutton-1.3 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + label .b1 -bitmap question -bd 3 -highlightthickness 4 + button .b2 -bitmap question -bd 3 -highlightthickness 0 + checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \ + -indicatoron 0 + radiobutton .b4 -bitmap question -bd 3 -highlightthickness 1 \ + -indicatoron false + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {31 41 25 35 25 35 25 35} +test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { + eval destroy [winfo children .] + label .b1 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} + button .b2 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} + checkbutton .b3 -text Xagqpim -padx 1 -pady 1 -font {Helvetica -18 bold} + radiobutton .b4 -text Xagqpim -padx 2 -pady 0 -font {Helvetica -18 bold} + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {82 29 88 35 114 31 121 29} +test unixbutton-1.5 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { + eval destroy [winfo children .] + 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] +} {136 88} +test unixbutton-1.6 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { + eval destroy [winfo children .] + 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] +} {231 46} +test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { + eval destroy [winfo children .] + label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 + button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 + checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2 + radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -width 4 + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {74 22 60 84 168 38 61 22} +test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { + eval destroy [winfo children .] + label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ + -highlightthickness 4 + button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \ + -highlightthickness 0 + checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 \ + -highlightthickness 1 -indicatoron no + radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0 + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {62 30 56 24 58 22 62 22} +test unixbutton-1.9 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + button .b2 -bitmap question -default active + list [winfo reqwidth .b2] [winfo reqheight .b2] +} {37 47} +test unixbutton-1.10 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + button .b2 -bitmap question -default normal + list [winfo reqwidth .b2] [winfo reqheight .b2] +} {37 47} +test unixbutton-1.11 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + button .b2 -bitmap question -default disabled + list [winfo reqwidth .b2] [winfo reqheight .b2] +} {27 37} + +eval destroy [winfo children .] diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test new file mode 100644 index 0000000..ef8ecb9 --- /dev/null +++ b/tests/unixEmbed.test @@ -0,0 +1,620 @@ +# This file is a Tcl script to test out the procedures in the file +# tkUnixEmbed.c. It is organized in the standard fashion for Tcl +# tests. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixEmbed.test 1.7 97/08/13 11:13:21 + +if {$tcl_platform(platform) != "unix"} { + return +} + +if {[info procs test] != "test"} { + source defs +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +setupbg +dobg {wm withdraw .} + +# eatColors -- +# Creates a toplevel window and allocates enough colors in it to +# use up all the slots in the colormap. +# +# Arguments: +# w - Name of toplevel window to create. + +proc eatColors {w} { + catch {destroy $w} + toplevel $w + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] + $w.c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } + } + update +} + +# colorsFree -- +# +# Returns 1 if there appear to be free colormap entries in a window, +# 0 otherwise. +# +# Arguments: +# w - Name of window in which to check. +# red, green, blue - Intensities to use in a trial color allocation +# to see if there are colormap entries free. + +proc colorsFree {w {red 31} {green 245} {blue 192}} { + set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] + expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ + && ([lindex $vals 2]/256 == $blue) +} + +test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} { + catch {destroy .t} + list [catch {toplevel .t -use xyz} msg] $msg +} {1 {expected integer but got "xyz"}} +test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} { + catch {destroy .t} + list [catch {toplevel .t -use 47} msg] $msg +} {1 {couldn't create child of window "47"}} +test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} { + catch {destroy .t} + catch {destroy .x} + toplevel .t -colormap new + wm geometry .t +0+0 + eatColors .t.t + frame .t.f -container 1 + toplevel .x -use [winfo id .t.f] + set result [colorsFree .x] + destroy .t + set result +} {0} +test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} { + catch {destroy .t} + catch {destroy .t2} + catch {destroy .x} + toplevel .t -container 1 -colormap new + wm geometry .t +0+0 + eatColors .t2 + toplevel .x -use [winfo id .t] + set result [colorsFree .x] + destroy .t + set result +} {1} +test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} { + eval destroy [winfo child .] + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -container 1 -width 200 -height 50 + pack .f1 .f2 + dobg "set w [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t -use $w + list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w] + } +} {{{XXX {} {} .t}} 0} +test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} { + eval destroy [winfo child .] + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -container 1 -width 200 -height 50 + pack .f1 .f2 + dobg "set w1 [winfo id .f1]" + dobg "set w2 [winfo id .f2]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + toplevel .t2 -use $w2 + testembed + } +} {{XXX {} {} .t2} {XXX {} {} .t1}} +test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} { + eval destroy [winfo child .] + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -container 1 -width 200 -height 50 + pack .f1 .f2 + toplevel .t1 -use [winfo id .f1] + toplevel .t2 -use [winfo id .f2] + testembed +} {{XXX .f2 {} .t2} {XXX .f1 {} .t1}} + +# Can't think of any way to test the procedures TkpMakeWindow, +# TkpMakeContainer, or EmbedErrorProc. + +test unixEmbed-2.1 {EmbeddedEventProc procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + testembed + } + destroy .f1 + update + dobg { + testembed + } +} {} +test unixEmbed-2.2 {EmbeddedEventProc procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + testembed + destroy .t1 + testembed + } +} {} +test unixEmbed-2.3 {EmbeddedEventProc procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + toplevel .t1 -use [winfo id .f1] + update + destroy .f1 + testembed +} {} +test unixEmbed-2.4 {EmbeddedEventProc procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + toplevel .t1 -use [winfo id .f1] + update + destroy .t1 + set x [testembed] + update + list $x [testembed] +} {{{XXX .f1 {} {}}} {}} + +test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + set x [testembed] + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + wm withdraw .t1 + } + list $x [testembed] +} {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}} +test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} { + foreach w [winfo child .] { + catch {destroy $w} + } + toplevel .t1 -container 1 + wm geometry .t1 +0+0 + toplevel .t2 -use [winfo id .t1] -bg red + update + wm geometry .t2 +} {200x200+0+0} +test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 -bd 2 -relief raised + update + wm geometry .t1 +30+40 + } + update + dobg { + wm geometry .t1 + } +} {200x200+0+0} +test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + update + wm geometry .t1 300x100+30+40 + } + update + dobg { + wm geometry .t1 + } +} {300x100+0+0} +test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + .t1 configure -width 300 -height 80 + } + update + list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}] +} {300 80 300x80+0+0} +test unixEmbed-3.5 {ContainerEventProc procedure, map requests} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + set x unmapped + bind .t1 <Map> {set x mapped} + } + update + dobg { + after 100 + update + set x + } +} {mapped} +test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + bind .f1 <Destroy> {set x dead} + set x alive + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + destroy .t1 + } + update + list $x [winfo exists .f1] +} {dead 0} + +test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + .t1 configure -width 180 -height 100 + } + update + dobg { + winfo geometry .t1 + } +} {180x100+0+0} +test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + set x [testembed] + destroy .f1 + list $x [testembed] +} {{{XXX .f1 XXX {}}} {}} + +test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + bind .t1 <FocusIn> {lappend x "focus in %W"} + bind .t1 <FocusOut> {lappend x "focus out %W"} + set x {} + } + focus -force .f1 + update + dobg {set x} +} {{focus in .t1}} +test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + after 200 {destroy .t1} + } + after 400 + focus -force .f1 + update +} {} +test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + bind .t1 <FocusIn> {lappend x "focus in %W"} + bind .t1 <FocusOut> {lappend x "focus out %W"} + set x {} + } + focus -force .f1 + update + set x [dobg {update; set x}] + focus . + update + list $x [dobg {update; set x}] +} {{{focus in .t1}} {{focus in .t1} {focus out .t1}}} + +test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + bind .t1 <Configure> {lappend x {configure .t1 %w %h}} + set x {} + .t1 configure -width 300 -height 120 + update + list $x [winfo geom .t1] + } +} {{{configure .t1 300 120}} 300x120+0+0} +test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + place .f1 -width 200 -height 200 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + after 300 {set x done} + vwait x + dobg { + bind .t1 <Configure> {lappend x {configure .t1 %w %h}} + set x {} + .t1 configure -width 300 -height 120 + update + list $x [winfo geom .t1] + } +} {{{configure .t1 200 200}} 200x200+0+0} + +# Can't think up any tests for TkpGetOtherWindow procedure. + +test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + focus -force . + bind . <KeyPress> {lappend x {key %A %E}} + set x {} + set y [dobg { + update + bind .t1 <KeyPress> {lappend y {key %A}} + set y {} + event generate .t1 <KeyPress> -keysym a + set y + }] + update + bind . <KeyPress> {} + list $x $y +} {{{key a 1}} {}} +test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + focus -force .f1 + update + bind . <KeyPress> {lappend x {key %A}} + set x {} + set y [dobg { + update + bind .t1 <KeyPress> {lappend y {key %A}} + set y {} + event generate .t1 <KeyPress> -keysym b + set y + }] + update + bind . <KeyPress> {} + list $x $y +} {{} {{key b}}} + +test unixEmbed-8.1 {TkpClaimFocus procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -width 200 -height 50 + pack .f1 .f2 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken + } + focus -force .f2 + update + list [dobg { + focus .t1 + set x [list [focus]] + update + after 500 + update + lappend x [focus] + }] [focus] +} {{{} .t1} .f1} +test unixEmbed-8.2 {TkpClaimFocus procedure} { + catch {interp delete child} + foreach w [winfo child .] { + catch {destroy $w} + } + 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 unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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 unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken + set x {} + lappend x [testembed] + destroy .t1 + lappend x [testembed] + } +} {{{XXX {} {} .t1}} {}} + +test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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 unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { + foreach w [winfo child .] { + catch {destroy $w} + } + 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} + + +foreach w [winfo child .] { + catch {destroy $w} +} +cleanupbg diff --git a/tests/unixFont.test b/tests/unixFont.test new file mode 100644 index 0000000..edcce42 --- /dev/null +++ b/tests/unixFont.test @@ -0,0 +1,293 @@ +# This file is a Tcl script to test out the procedures in tkUnixFont.c. +# It is organized in the standard fashion for Tcl tests. +# +# Many 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. Some tests depend on the +# fonts having or not having certain properties, which may not be valid +# at all sites. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixFont.test 1.7 97/06/24 13:34:24 + +if {$tcl_platform(platform)!="unix"} { + return +} + +if {[string compare test [info procs test]] != 0} { + source defs +} + +catch {destroy .b} +toplevel .b +wm geom .b +0+0 +update idletasks + +# Font should be fixed width and have chars missing below char 32, so can +# test control char expansion and missing character code. + +set courier {Courier -10} +set cx [font measure $courier 0] + +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]" +} + +test unixfont-1.1 {TkpGetNativeFont procedure: not native} { + list [catch {font measure {} xyz} msg] $msg +} {1 {font "" doesn't exist}} +test unixfont-1.2 {TkpGetNativeFont procedure: native} { + font measure fixed 0 +} {6} + +test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} { + font actual {-size 10} + set x {} +} {} +test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} { + set x {} + lappend x [lindex [font actual {-family "Times New Roman"}] 1] + lappend x [lindex [font actual {-family "New York"}] 1] + lappend x [lindex [font actual {-family "Times"}] 1] +} {times times times} +test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} { + set x {} + lappend x [lindex [font actual {-family "Courier New"}] 1] + lappend x [lindex [font actual {-family "Monaco"}] 1] + lappend x [lindex [font actual {-family "Courier"}] 1] +} {courier courier courier} +test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} { + set x {} + lappend x [lindex [font actual {-family "Arial"}] 1] + lappend x [lindex [font actual {-family "Geneva"}] 1] + lappend x [lindex [font actual {-family "Helvetica"}] 1] +} {helvetica helvetica helvetica} +test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} { + font actual {-xyz-xyz-*-*-*-*-*-*-*-*-*-*-*-*} + set x {} +} {} +test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} { + lindex [font actual {-family fixed -size 10}] 1 +} {fixed} +test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} { + # no test available +} {} +test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} { + lindex [font actual {-family fixed -size 31}] 1 +} {fixed} +test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} { + lindex [font actual {-family courier}] 1 +} {courier} +test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} { + lindex [font actual {-family courier -size 37}] 3 +} {37} +test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} { + # On Linux, XListFonts() was returning names for fonts that do not + # actually exist, causing the subsequent XLoadQueryFont() to fail + # unexpectedly. Now falls back to another font if that happens. + + font actual {-size 14} + set x {} +} {} + +test unixfont-3.1 {TkpDeleteFont procedure} { + font actual {-family xyz} + set x {} +} {} + +test unixfont-4.1 {TkpGetFontFamilies procedure} { + font families + set x {} +} {} + +test unixfont-5.1 {Tk_MeasureChars procedure: no chars to be measured} { + .b.l config -text "000000" -wrap [expr $ax*3] + .b.l config -wrap 0 +} {} +test unixfont-5.2 {Tk_MeasureChars procedure: no right margin} { + .b.l config -text "000000" +} {} +test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} { + .b.l config -text "0" + .b.l config -text "\377" + .b.l config -text "0\3770\377" + .b.l config -text "000000000000000" +} {} +.b.l config -wrap [expr $ax*10] +test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} { + .b.l config -text "0000000000000" + getsize +} "[expr $ax*10] [expr $ay*2]" +test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} { + .b.l config -text "000000" + getsize +} "[expr $ax*6] $ay" +test unixfont-5.6 {Tk_MeasureChars procedure: find last word} { + .b.l config -text "000000 00000" + getsize +} "[expr $ax*6] [expr $ay*2]" +test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} { + .b.l config -text "000000 00000" + getsize +} "[expr $ax*6] [expr $ay*2]" +test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} { + .b.l config -text "00 000 00000" + getsize +} "[expr $ax*7] [expr $ay*2]" +test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} { + .b.c dchars $t 0 end + .b.c insert $t 0 "0000" + .b.c index $t @[expr int($ax*2.5)],1 +} {2} +test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} { + .b.l config -text "000000000000" + getsize +} "[expr $ax*10] [expr $ay*2]" +test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} { + set a [.b.l cget -wrap] + .b.l config -text "000000" -wrap 1 + set x [getsize] + .b.l config -wrap $a + set x +} "$ax [expr $ay*6]" +test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} { + .b.l config -text "000 \n000" + getsize +} "[expr $ax*6] [expr $ay*2]" + +test unixfont-6.1 {Tk_DrawChars procedure: loop test} { + .b.l config -text "a" + update +} {} +test unixfont-6.2 {Tk_DrawChars procedure: loop test} { + .b.l config -text "abcd" + update +} {} +test unixfont-6.3 {Tk_DrawChars procedure: special char} { + .b.l config -text "\001" + update +} {} +test unixfont-6.4 {Tk_DrawChars procedure: normal then special} { + .b.l config -text "ab\001" + update +} {} +test unixfont-6.5 {Tk_DrawChars procedure: ends with special} { + .b.l config -text "ab\001" + update +} {} +test unixfont-6.6 {Tk_DrawChars procedure: more normal chars at end} { + .b.l config -text "ab\001def" + update +} {} + +test unixfont-7.1 {DrawChars procedure: no effects} { + .b.l config -text "abc" + update +} {} +test unixfont-7.2 {DrawChars procedure: underlining} { + set f [.b.l cget -font] + .b.l config -text "abc" -font "courier 10 underline" + update + .b.l config -font $f +} {} +test unixfont-7.3 {DrawChars procedure: overstrike} { + set f [.b.l cget -font] + .b.l config -text "abc" -font "courier 10 overstrike" + update + .b.l config -font $f +} {} + +test unixfont-8.1 {AllocFont procedure: use old font} { + font create xyz + button .c -font xyz + font configure xyz -family times + update + destroy .c + font delete xyz +} {} +test unixfont-8.2 {AllocFont procedure: parse information from XLFD} { + expr [lindex [font actual {-family times -size 0}] 3]==0 +} {0} +test unixfont-8.3 {AllocFont procedure: can't parse info from name} { + if [catch {set a [font actual a12biluc]}]==0 { + string compare $a "-family a12biluc -size 0 -weight normal -slant roman -underline 0 -overstrike 0" + } else { + set a 0 + } +} {0} +test unixfont-8.4 {AllocFont procedure: classify characters} { + set x 0 + incr x [font measure $courier "\001"] ;# 4 + incr x [font measure $courier "\002"] ;# 4 + incr x [font measure $courier "\012"] ;# 2 + incr x [font measure $courier "\101"] ;# 1 + set x +} [expr $cx*11] +test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} { + font metrics $courier -fixed +} {1} +test unixfont-8.6 {AllocFont procedure: setup widths of special chars} { + set x 0 + incr x [font measure $courier "\001"] ;# 4 + incr x [font measure $courier "\002"] ;# 4 + incr x [font measure $courier "\012"] ;# 2 + set x +} [expr $cx*10] +test unixfont-8.7 {AllocFont procedure: XA_UNDERLINE_POSITION} { + catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1} + set x {} +} {} +test unixfont-8.8 {AllocFont procedure: no XA_UNDERLINE_POSITION} { + catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific} + set x {} +} {} +test unixfont-8.9 {AllocFont procedure: XA_UNDERLINE_THICKNESS} { + catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1} + set x {} +} {} +test unixfont-8.10 {AllocFont procedure: no XA_UNDERLINE_THICKNESS} { + catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific} + set x {} +} {} +test unixfont-8.11 {AllocFont procedure: XA_UNDERLINE_POSITION was 0} { + catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1} + set x {} +} {} + +test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} { + .b.c dchars $t 0 end + .b.c insert $t 0 "0\a0" + set x {} + lappend x [.b.c index $t @[expr $ax*0],0] + lappend x [.b.c index $t @[expr $ax*1],0] + lappend x [.b.c index $t @[expr $ax*2],0] + lappend x [.b.c index $t @[expr $ax*3],0] +} {0 1 1 2} +test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} { + .b.c dchars $t 0 end + .b.c insert $t 0 "0\1770" + set x {} + lappend x [.b.c index $t @[expr $ax*0],0] + lappend x [.b.c index $t @[expr $ax*1],0] + lappend x [.b.c index $t @[expr $ax*2],0] + lappend x [.b.c index $t @[expr $ax*3],0] + lappend x [.b.c index $t @[expr $ax*4],0] + lappend x [.b.c index $t @[expr $ax*5],0] +} {0 1 1 1 1 2} + diff --git a/tests/unixMenu.test b/tests/unixMenu.test new file mode 100644 index 0000000..dfcf252 --- /dev/null +++ b/tests/unixMenu.test @@ -0,0 +1,969 @@ +# 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-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixMenu.test 1.9 97/06/24 13:52:38 + +if {$tcl_platform(platform) != "unix"} { + return +} + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +proc deleteWindows {} { + foreach i [winfo children .] { + catch [destroy $i] + } +} + +deleteWindows +wm geometry . {} +raise . + +test unixMenu-1.1 {TkpNewMenu - normal menu} { + catch {destroy .m1} + list [catch {menu .m1} msg] $msg [destroy .m1] +} {0 .m1 {}} +test unixMenu-1.2 {TkpNewMenu - help menu} { + catch {destroy .m1} + menu .m1 -tearoff 0 + . configure -menu .m1 + .m1 add cascade -label Help -menu .m1.help + list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 .m1.help {} {}} + +test unixMenu-2.1 {TkpDestroyMenu - nothing to do} {} {} +test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} {} {} + +test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add command -label test + list [catch {.m1 entryconfigure test -label foo} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -menu .m2 -label test + menu .m1.foo -tearoff 0 + list [catch {.m1 entryconfigure test -menu .m1.foo} msg] $msg [destroy .m1] +} {0 {} {}} + +test unixMenu-5.1 {TkpMenuNewEntry - nothing to do} {} {} + +test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + . configure -menu .m1 + list [catch {. configure -menu ""} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-6.2 {TkpSetWindowMenuBar - menu} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} + +test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} {} {} + +test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo -indicatoron 0 + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} { + catch {destroy .m1} + catch {image delete image1} + menu .m1 + image create test image1 + .m1 add checkbutton -image image1 -label foo + .m1 invoke foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] [image delete image1] +} {0 {} {}} +test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -bitmap questhead -label foo + .m1 invoke foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} { + catch {destroy .m1} + catch {image delete image1} + menu .m1 + image create test image1 + .m1 add radiobutton -image image1 -label foo + .m1 invoke foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] [image delete image1] +} {0 {} {}} +test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -bitmap questhead -label foo + .m1 invoke foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -label foo + .m1 invoke foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -label foo -hidemargin 1 + .m1 invoke foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Ctrl+S" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test unixMenu-9.3 {GetMenuAccelGeometry - null label} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + . configure -menu .m1 + .m1 activate 1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-10.2 {DrawMenuEntryBackground - active} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + $tearoff activate 0 + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-10.3 {DrawMenuEntryBackground - non-active} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Ctrl+U" + . configure -menu .m1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +# drawArrow parameter is never false under Unix +test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Ctrl+U" + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo -indicatoron 0 + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke 1 + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -label foo -indicatoron 0 + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} +test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -label foo + .m1 invoke 1 + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +test unixMenu-13.1 {DrawMenuSeparator - menubar case} { + catch {destroy .m1} + menu .m1 + .m1 add separator + . configure -menu .m1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-13.2 {DrawMenuSepartor - normal menu} { + catch {destroy .m1} + menu .m1 + .m1 add separator + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +test unixMenu-14.1 {DrawMenuEntryLabel} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +test unixMenu-15.1 {DrawMenuUnderline - menubar} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -underline 0 + . configure -menu .m1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-15.2 {DrawMenuUnderline - no menubar} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -underline 0 + set tearoff [tkTearOffMenu .m1 40 40] + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +test unixMenu-16.1 {TkpPostMenu} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +test unixMenu-17.1 {GetMenuSeparatorGeometry} { + catch {destroy .m1} + menu .m1 + .m1 add separator + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +test unixMenu-18.1 {GetTearoffEntryGeometry} { + catch {destroy .m1} + menubutton .mb -text "test" -menu .mb.m + menu .mb.m + .mb.m add command -label test + pack .mb + raise . + list [catch {tkMbPost .mb} msg] $msg [destroy .mb] +} {0 {} {}} + +# Don't know how to reproduce the case where the tkwin has been deleted. +test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} { + catch {destroy .m1} + menu .m1 + . configure -menu .m1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +# Don't know how to generate one width windows +test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label File + . configure -menu .m1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} { + catch {destroy .m1} + menu .m1 -font "Courier 24" + .m1 add cascade -label File -font "Helvetica 18" + . configure -menu .m1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} { + catch {destroy .m1} + menu .m1 + .m1 add separator + . configure -menu .m1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label File + . configure -menu .m1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label File -font "Times 72" + . configure -menu .m1 + wm geometry . 10x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label File + .m1 add cascade -label Edit + . configure -menu .m1 + wm geometry . 200x200 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label File + .m1 add cascade -label Edit -font "Times 72" + . configure -menu .m1 + wm geometry . 100x100 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label File -font "Times 72" + .m1 add cascade -label Edit + . configure -menu .m1 + wm geometry . 100x100 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} { + catch {destroy .m1} + menu .m1 -tearoff 0 -font "Times 72" + .m1 add cascade -label File + .m1 add cascade -label Edit + . configure -menu .m1 + wm geometry . 10x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +# ABC notation; capital A means first window fits, small a means it +# does not. capital B menu means second window fist, etc. +test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} { + catch {destroy .m1} + menu .m1 -tearoff 0 -font "Times 72" + .m1 add cascade -label "aaaaa" + .m1 add cascade -label "bbbbb" + .m1 add cascade -label "ccccc" + . configure -menu .m1 + wm geometry . 10x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label "aaaaa" -font "Times 72" + .m1 add cascade -label "bbbbb" -font "Times 72" + .m1 add cascade -label "C" + . configure -menu .m1 + wm geometry . 10x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label "aaaaa" -font "Times 72" + .m1 add cascade -label "B" + .m1 add cascade -label "ccccc" -font "Times 72" + . configure -menu .m1 + wm geometry . 10x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label "aaaaa" -font "Times 72" + .m1 add cascade -label "B" + .m1 add cascade -label "C" + . configure -menu .m1 + wm geometry . 60x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label "A" + .m1 add cascade -label "bbbbb" -font "Times 72" + .m1 add cascade -label "ccccc" -font "Times 72" + . configure -menu .m1 + wm geometry . 60x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label "A" + .m1 add cascade -label "bbbbb" -font "Times 72" + .m1 add cascade -label "C" + . configure -menu .m1 + wm geometry . 60x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label "A" + .m1 add cascade -label "B" + .m1 add cascade -label "ccccc" -font "Times 72" + . configure -menu .m1 + wm geometry . 60x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label "A" + .m1 add cascade -label "B" + .m1 add cascade -label "C" + . configure -menu .m1 + wm geometry . 100x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label Help -menu .m1.help + menu .m1.help -tearoff 0 + .m1 add cascade -label File -menu .m1.file + menu .m1.file -tearoff 0 + .m1 add cascade -label Edit -menu .m1.edit + menu .m1.edit -tearoff 0 + . configure -menu .m1 + wm geometry . 100x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label Edit -menu .m1.edit + menu .m1.edit -tearoff 0 + .m1 add cascade -label Help -menu .m1.help + menu .m1.help -tearoff 0 + .m1 add cascade -label File -menu .m1.file + menu .m1.file -tearoff 0 + . configure -menu .m1 + wm geometry . 100x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label File -menu .m1.file + menu .m1.file -tearoff 0 + .m1 add cascade -label Edit -menu .m1.edit + menu .m1.edit -tearoff 0 + .m1 add cascade -label Help -menu .m1.help + menu .m1.help -tearoff 0 + . configure -menu .m1 + wm geometry . 100x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label File -menu .m1.file + menu .m1.file -tearoff 0 + .m1 add cascade -label Help -menu .m1.help + menu .m1.help -tearoff 0 + . configure -menu .m1 + wm geometry . 100x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label File -menu .m1.file + menu .m1.file -tearoff 0 + .m1 add cascade -label Help -menu .m1.help -font "Helvetica 72" + menu .m1.help -tearoff 0 + . configure -menu .m1 + wm geometry . 100x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label Help -menu .m1.help + menu .m1.help -tearoff 0 + . configure -menu .m1 + wm geometry . 100x10 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} + +test unixMenu-20.1 {DrawTearoffEntry - menubar} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label File + . configure -menu .m1 + list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test unixMenu-20.2 {DrawTearoffEntry - non-menubar} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + .m1 post 40 40 + list [catch {update} msg] $msg [destroy .m1] +} {0 {} {}} + +test unixMenu-21.1 {TkpInitializeMenuBindings - nothing to do} {} {} + +test unixMenu-22.1 {SetHelpMenu - no menubars} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -label test -menu .m1.test + list [catch {menu .m1.test} msg] $msg [destroy .m1] +} {0 .m1.test {}} +# Don't know how to automate missing tkwins +test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} { + catch {destroy .m1} + menu .m1 -tearoff 0 + . configure -menu .m1 + .m1 add cascade -label .m1.file + list [catch {menu .m1.file} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 .m1.file {} {}} +test unixMenu-22.3 {SetHelpMenu - menubar with help menu} { + catch {destroy .m1} + menu .m1 -tearoff 0 + . configure -menu .m1 + .m1 add cascade -label .m1.help + list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 .m1.help {} {}} +test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} { + catch {destroy .m1} + catch {destroy .t2} + toplevel .t2 + wm geometry .t2 +40+40 + menu .m1 -tearoff 0 + . configure -menu .m1 + .t2 configure -menu .m1 + .m1 add cascade -label .m1.help + list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] [destroy .t2] +} {0 .m1.help {} {} {}} + +test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -activeforeground red + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} { + catch {destroy .m1} + menu .m1 + set tk_strictMotif 1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] [set tk_strictMotif 0] +} {{} {} 0} +test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} { + catch {destroy .m1} + menu .m1 -disabledforeground blue + .m1 add command -label foo -state disabled -background red + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} { + catch {destroy .m1} + menu .m1 -disabledforeground blue + .m1 add command -label foo -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} { + catch {destroy .m1} + menu .m1 -disabledforeground "" + .m1 add command -label foo -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -foreground red + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo -selectcolor orange + .m1 invoke 1 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke 1 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -activebackground green + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.12 {TkpDrawMenuEntry - border} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} { + catch {destroy .m1} + set tk_strictMotif 1 + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] [set tk_strictMotif 0] +} {{} {} 0} +test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -activeforeground yellow + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.15 {TkpDrawMenuEntry - active border} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -font "Helvectica 72" + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.17 {TkpDrawMenuEntry - font} { + catch {destroy .m1} + menu .m1 -font "Courier 72" + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.18 {TkpDrawMenuEntry - separator} { + catch {destroy .m1} + menu .m1 + .m1 add separator + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.19 {TkpDrawMenuEntry - standard} { + catch {destroy .mb} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} { + 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 [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.21 {TkpDrawMenuEntry - indicator} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label Foo + .m1 invoke Foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label Foo -hidemargin 1 + .m1 invoke Foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} + +test unixMenu-24.1 {GetMenuLabelGeometry - image} { + 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 unixMenu-24.2 {GetMenuLabelGeometry - bitmap} { + catch {destroy .m1} + menu .m1 + .m1 add command -bitmap questhead + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-24.3 {GetMenuLabelGeometry - no text} { + catch {destroy .m1} + menu .m1 + .m1 add command + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-24.4 {GetMenuLabelGeometry - text} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "This is a test." + list [update idletasks] [destroy .m1] +} {{} {}} + +test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} { + catch {destroy .m1} + menu .m1 + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "one" + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "one" + .m1 add command -label "two" + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} { + catch {destroy .m1} + menu .m1 + .m1 add separator + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} { + catch {destroy .m1} + menubutton .mb -text "test" -menu .mb.m + menu .mb.m + .mb.m add command -label test + pack .mb + catch {tkMbPost .mb} + list [update] [destroy .mb] +} {{} {}} +test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} { + catch {destroy .m1} + menu .m1 -font "Helvetica 12" + .m1 add command -label "test" -font "Courier 12" + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 add command -label "test test" + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test test" + .m1 add command -label "test" + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" -accel "Ctrl+S" + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} { + 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 unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} { + 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 unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label test + .m1 invoke 1 + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } { + 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 unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unixOnly} { + 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 unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} { + catch {destroy .m1} + menu .m1 -tearoff 0 + list [update idletasks] [destroy .m1] +} {{} {}} +test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} { + 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 unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} { + 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 unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} { + 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 unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add checkbutton -label one -hidemargin 1 + list [update idletasks] [destroy .m1] +} {{} {}} + +test unixMenu-26.1 {TkpMenuInit - nothing to do} {} {} + +deleteWindows diff --git a/tests/unixWm.test b/tests/unixWm.test new file mode 100644 index 0000000..b165826 --- /dev/null +++ b/tests/unixWm.test @@ -0,0 +1,2352 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixWm.test 1.46 97/10/27 16:15:36 + +if {$tcl_platform(platform) != "unix"} { + return +} + +if {[string compare test [info procs test]] == 1} { + source defs +} + +proc sleep ms { + global x + after $ms {set x 1} + vwait x +} + +# Procedure to set up a collection of top-level windows + +proc makeToplevels {} { + foreach i [winfo child .] { + destroy $i + } + foreach i {.raise1 .raise2 .raise3} { + toplevel $i + wm geom $i 150x100+0+0 + update + } +} + +set i 1 +foreach geom {+20+80 +80+20 +0+0} { + catch {destroy .t} + test unixWm-1.$i {initial window position} { + toplevel .t -width 200 -height 150 + wm geom .t $geom + update + wm geom .t + } 200x150$geom + incr i +} + +# The tests below are tricky because window managers don't all move +# windows correctly. Try one motion and compute the window manager's +# error, then factor this error into the actual tests. In other words, +# this just makes sure that things are consistent between moves. + +set i 1 +catch {destroy .t} +toplevel .t -width 100 -height 150 +wm geom .t +200+200 +update +wm geom .t +150+150 +update +scan [wm geom .t] %dx%d+%d+%d width height x y +set xerr [expr 150-$x] +set yerr [expr 150-$y] +foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} { + test unixWm-2.$i {moving window while mapped} { + wm geom .t $geom + update + scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y + format "%s%d%s%d" $xsign [eval expr $x$xsign$xerr] $ysign \ + [eval expr $y$ysign$yerr] + } $geom + incr i +} + +set i 1 +foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} { + test unixWm-3.$i {moving window while iconified} { + wm iconify .t + sleep 200 + wm geom .t $geom + update + wm deiconify .t + scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y + format "%s%d%s%d" $xsign [eval expr $x$xsign$xerr] $ysign \ + [eval expr $y$ysign$yerr] + } $geom + incr i +} + +set i 1 +foreach geom {+20+80 +100+40 +0+0} { + test unixWm-4.$i {moving window while withdrawn} { + wm withdraw .t + sleep 200 + wm geom .t $geom + update + wm deiconify .t + wm geom .t + } 100x150$geom + incr i +} + +test unixWm-5.1 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm withdraw .t + wm deiconify .t + list [winfo ismapped .t] [wm state .t] +} {1 normal} +test unixWm-5.2 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm withdraw .t + wm deiconify .t + wm withdraw .t + list [winfo ismapped .t] [wm state .t] +} {0 withdrawn} +test unixWm-5.3 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm iconify .t + wm deiconify .t + wm iconify .t + wm deiconify .t + list [winfo ismapped .t] [wm state .t] +} {1 normal} +test unixWm-5.4 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm iconify .t + wm deiconify .t + wm iconify .t + list [winfo ismapped .t] [wm state .t] +} {0 iconic} +test unixWm-5.5 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm iconify .t + wm withdraw .t + list [winfo ismapped .t] [wm state .t] +} {0 withdrawn} +test unixWm-5.6 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm iconify .t + wm withdraw .t + wm deiconify .t + list [winfo ismapped .t] [wm state .t] +} {1 normal} +test unixWm-5.7 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm withdraw .t + wm iconify .t + list [winfo ismapped .t] [wm state .t] +} {0 iconic} + +catch {destroy .t} +toplevel .t -width 200 -height 100 +wm geom .t +10+10 +wm minsize .t 1 1 +update +test unixWm-6.1 {size changes} { + .t config -width 180 -height 150 + update + wm geom .t +} 180x150+10+10 +test unixWm-6.2 {size changes} { + wm geom .t 250x60 + .t config -width 170 -height 140 + update + wm geom .t +} 250x60+10+10 +test unixWm-6.3 {size changes} { + wm geom .t 250x60 + .t config -width 170 -height 140 + wm geom .t {} + update + wm geom .t +} 170x140+10+10 +test unixWm-6.4 {size changes} {nonPortable} { + wm minsize .t 1 1 + update + puts stdout "Please resize window \"t\" with the mouse (but don't move it!)," + puts -nonewline stdout "then hit return: " + flush stdout + gets stdin + update + set width [winfo width .t] + set height [winfo height .t] + .t config -width 230 -height 110 + update + incr width -[winfo width .t] + incr height -[winfo height .t] + wm geom .t {} + update + set w2 [winfo width .t] + set h2 [winfo height .t] + .t config -width 114 -height 261 + update + list $width $height $w2 $h2 [wm geom .t] +} {0 0 230 110 114x261+10+10} + +# I don't know why the wait below is needed, but without it the test +# fails under twm. +sleep 200 + +test unixWm-6.5 {window initially iconic} {nonPortable} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + wm geometry .t +0+0 + wm title .t 2 + wm iconify .t + update idletasks + wm withdraw .t + wm deiconify .t + list [winfo ismapped .t] [wm state .t] +} {1 normal} + +catch {destroy .m} +toplevel .m +wm overrideredirect .m 1 +foreach i {{Test label} Another {Yet another} {Last label}} j {1 2 3} { + label .m.$j -text $i +} +wm geometry .m +[expr 100 - [winfo vrootx .]]+[expr 200 - [winfo vrooty .]] +update +test unixWm-7.1 {override_redirect and Tk_MoveTopLevelWindow} { + list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m] +} {1 normal 100 200} +wm geometry .m +[expr 150 - [winfo vrootx .]]+[expr 210 - [winfo vrooty .]] +update +test unixWm-7.2 {override_redirect and Tk_MoveTopLevelWindow} { + list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m] +} {1 normal 150 210} +wm withdraw .m +test unixWm-7.3 {override_redirect and Tk_MoveTopLevelWindow} { + list [winfo ismapped .m] +} 0 +destroy .m +catch {destroy .t} + +test unixWm-8.1 {icon windows} { + catch {destroy .t} + catch {destroy .icon} + toplevel .t -width 100 -height 30 + wm geometry .t +0+0 + toplevel .icon -width 50 -height 50 -bg red + wm iconwindow .t .icon + list [catch {wm withdraw .icon} msg] $msg +} {1 {can't withdraw .icon: it is an icon for .t}} +test unixWm-8.2 {icon windows} { + catch {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} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + list [catch {wm iconwindow .t b c} msg] $msg +} {1 {wrong # arguments: must be "wm iconwindow window ?pathName?"}} +test unixWm-8.4 {icon windows} { + catch {destroy .t} + catch {destroy .icon} + toplevel .t -width 100 -height 30 + wm geom .t +0+0 + set result [wm iconwindow .t] + toplevel .icon -width 50 -height 50 -bg red + wm iconwindow .t .icon + lappend result [wm iconwindow .t] [wm state .icon] + wm iconwindow .t {} + lappend result [wm iconwindow .t] [wm state .icon] + update + lappend result [winfo ismapped .t] [winfo ismapped .icon] + wm iconify .t + update + lappend result [winfo ismapped .t] [winfo ismapped .icon] +} {.icon icon {} withdrawn 1 0 0 0} +test unixWm-8.5 {icon windows} { + catch {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} { + catch {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} { + catch {destroy .t} + catch {destroy .icon} + toplevel .t -width 100 -height 30 + wm geom .t +0+0 + toplevel .icon -width 50 -height 50 -bg red + toplevel .icon2 -width 50 -height 50 -bg green + wm iconwindow .t .icon + set result "[wm iconwindow .t] [wm state .icon] [wm state .icon2]" + wm iconwindow .t .icon2 + lappend result [wm iconwindow .t] [wm state .icon] [wm state .icon2] +} {.icon icon normal .icon2 withdrawn icon} +catch {destroy .icon2} +test unixWm-8.8 {icon windows} { + catch {destroy .t} + catch {destroy .icon} + toplevel .icon -width 50 -height 50 -bg red + wm geom .icon +0+0 + update + set result [winfo ismapped .icon] + toplevel .t -width 100 -height 30 + wm geom .t +0+0 + tkwait visibility .t ;# Needed to keep tvtwm happy. + wm iconwindow .t .icon + sleep 500 + lappend result [winfo ismapped .t] [winfo ismapped .icon] +} {1 1 0} +test unixWm-8.9 {icon windows} {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} + toplevel .t -width 100 -height 30 + toplevel .icon -width 50 -height 50 -bg red + wm geom .t +0+0 + wm iconwindow .t .icon + update + set result "[wm state .icon] [winfo ismapped .t] [winfo ismapped .icon]" + destroy .t + wm geom .icon +0+0 + update + lappend result [winfo ismapped .icon] [wm state .icon] + wm deiconify .icon + update + lappend result [winfo ismapped .icon] [wm state .icon] +} {icon 1 0 0 withdrawn 1 normal} + +test unixWm-9.1 {TkWmMapWindow procedure, client property} {unixOnly} { + catch {destroy .t} + toplevel .t -width 100 -height 50 + wm geom .t +0+0 + wm client .t Test_String + update + testprop [testwrapper .t] WM_CLIENT_MACHINE +} {Test_String} +test unixWm-9.2 {TkWmMapWindow procedure, command property} {unixOnly} { + catch {destroy .t} + toplevel .t -width 100 -height 50 + wm geom .t +0+0 + wm command .t "test command" + update + testprop [testwrapper .t] WM_COMMAND +} {test +command +} +test unixWm-9.3 {TkWmMapWindow procedure, iconic windows} { + catch {destroy .t} + toplevel .t -width 100 -height 300 -bg blue + wm geom .t +0+0 + wm iconify .t + sleep 500 + winfo ismapped .t +} {0} +test unixWm-9.4 {TkWmMapWindow procedure, icon windows} { + catch {destroy .t} + sleep 500 + toplevel .t -width 100 -height 50 -bg blue + wm iconwindow . .t + update + set result [winfo ismapped .t] +} {0} +test unixWm-9.5 {TkWmMapWindow procedure, normal windows} { + catch {destroy .t} + toplevel .t -width 200 -height 20 + wm geom .t +0+0 + update + winfo ismapped .t +} {1} + +test unixWm-10.1 {TkWmDeadWindow procedure, canceling UpdateGeometry idle handler} { + catch {destroy .t} + toplevel .t -width 100 -height 50 + wm geom .t +0+0 + update + .t configure -width 200 -height 100 + destroy .t +} {} +test unixWm-10.2 {TkWmDeadWindow procedure, destroying menubar} {unixOnly} { + catch {destroy .t} + catch {destroy .f} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + wm geom .t +0+0 + update + frame .f -width 400 -height 30 -bd 2 -relief raised -bg green + bind .f <Destroy> {lappend result destroyed} + testmenubar window .t .f + update + set result {} + destroy .t + lappend result [winfo exists .f] +} {destroyed 0} + +test unixWm-11.1 {Tk_WmCmd procedure, miscellaneous errors} { + list [catch {wm} msg] $msg +} {1 {wrong # args: should be "wm option window ?arg ...?"}} +test unixWm-11.2 {Tk_WmCmd procedure, miscellaneous errors} { + list [catch {wm foo} msg] $msg +} {1 {wrong # args: should be "wm option window ?arg ...?"}} +test unixWm-11.3 {Tk_WmCmd procedure, miscellaneous errors} { + list [catch {wm foo bogus} msg] $msg +} {1 {bad window path name "bogus"}} +test unixWm-11.4 {Tk_WmCmd procedure, miscellaneous errors} { + catch {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} + +toplevel .t -width 100 -height 50 +wm geom .t +0+0 +update + +test unixWm-12.1 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t 12} msg] $msg +} {1 {wrong # arguments: must be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}} +test unixWm-12.2 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t 12 13 14 15 16} msg] $msg +} {1 {wrong # arguments: must be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}} +test unixWm-12.3 {Tk_WmCmd procedure, "aspect" option} { + set result {} + 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] +} {{} {3 4 10 2} {}} +test unixWm-12.4 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t bad 14 15 16} msg] $msg +} {1 {expected integer but got "bad"}} +test unixWm-12.5 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t 13 foo 15 16} msg] $msg +} {1 {expected integer but got "foo"}} +test unixWm-12.6 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t 13 14 bar 16} msg] $msg +} {1 {expected integer but got "bar"}} +test unixWm-12.7 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t 13 14 15 baz} msg] $msg +} {1 {expected integer but got "baz"}} +test unixWm-12.8 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t 0 14 15 16} msg] $msg +} {1 {aspect number can't be <= 0}} +test unixWm-12.9 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t 13 0 15 16} msg] $msg +} {1 {aspect number can't be <= 0}} +test unixWm-12.10 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t 13 14 0 16} msg] $msg +} {1 {aspect number can't be <= 0}} +test unixWm-12.11 {Tk_WmCmd procedure, "aspect" option} { + list [catch {wm aspect .t 13 14 15 0} msg] $msg +} {1 {aspect number can't be <= 0}} + +test unixWm-13.1 {Tk_WmCmd procedure, "client" option} { + list [catch {wm client .t x y} msg] $msg +} {1 {wrong # arguments: must be "wm client window ?name?"}} +test unixWm-13.2 {Tk_WmCmd procedure, "client" option} {unixOnly} { + set result {} + lappend result [wm client .t] + wm client .t Test_String + lappend result [testprop [testwrapper .t] WM_CLIENT_MACHINE] + wm client .t New + lappend result [wm client .t] + wm client .t {} + 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} { + catch {destroy .t2} + toplevel .t2 + wm client .t2 Test_String + wm client .t2 {} + wm client .t2 Test_String + destroy .t2 +} {} + +test unixWm-14.1 {Tk_WmCmd procedure, "colormapwindows" option} { + list [catch {wm colormapwindows .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm colormapwindows window ?windowList?"}} +test unixWm-14.2 {Tk_WmCmd procedure, "colormapwindows" option} { + catch {destroy .t2} + toplevel .t2 -width 200 -height 200 -colormap new + wm geom .t2 +0+0 + frame .t2.a -width 100 -height 30 + frame .t2.b -width 100 -height 30 -colormap new + pack .t2.a .t2.b -side top + update + set x [wm colormapwindows .t2] + frame .t2.c -width 100 -height 30 -colormap new + pack .t2.c -side top + update + list $x [wm colormapwindows .t2] +} {{.t2.b .t2} {.t2.b .t2.c .t2}} +test unixWm-14.3 {Tk_WmCmd procedure, "colormapwindows" option} { + list [catch {wm col . "a \{"} msg] $msg +} {1 {unmatched open brace in list}} +test unixWm-14.4 {Tk_WmCmd procedure, "colormapwindows" option} { + list [catch {wm colormapwindows . foo} msg] $msg +} {1 {bad window path name "foo"}} +test unixWm-14.5 {Tk_WmCmd procedure, "colormapwindows" option} { + catch {destroy .t2} + toplevel .t2 -width 200 -height 200 -colormap new + wm geom .t2 +0+0 + frame .t2.a -width 100 -height 30 + frame .t2.b -width 100 -height 30 + frame .t2.c -width 100 -height 30 + pack .t2.a .t2.b .t2.c -side top + wm colormapwindows .t2 {.t2.c .t2 .t2.a} + wm colormapwindows .t2 +} {.t2.c .t2 .t2.a} +test unixWm-14.6 {Tk_WmCmd procedure, "colormapwindows" option} { + catch {destroy .t2} + toplevel .t2 -width 200 -height 200 + wm geom .t2 +0+0 + frame .t2.a -width 100 -height 30 + frame .t2.b -width 100 -height 30 + frame .t2.c -width 100 -height 30 + pack .t2.a .t2.b .t2.c -side top + wm colormapwindows .t2 {.t2.b .t2.a} + wm colormapwindows .t2 +} {.t2.b .t2.a} +test unixWm-14.7 {Tk_WmCmd procedure, "colormapwindows" option} { + catch {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} + +test unixWm-15.1 {Tk_WmCmd procedure, "command" option} { + list [catch {wm command .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm command window ?value?"}} +test unixWm-15.2 {Tk_WmCmd procedure, "command" option} { + list [catch {wm command .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm command window ?value?"}} +test unixWm-15.3 {Tk_WmCmd procedure, "command" option} {unixOnly} { + set result {} + lappend result [wm command .t] + wm command .t "test command" + lappend result [testprop [testwrapper .t] WM_COMMAND] + wm command .t "new command" + lappend result [wm command .t] + wm command .t {} + lappend result [wm command .t] [testprop [testwrapper .t] WM_COMMAND] +} {{} {test +command +} {new command} {} {}} +test unixWm-15.4 {Tk_WmCmd procedure, "command" option, window not mapped} { + catch {destroy .t2} + toplevel .t2 + wm geom .t2 +0+0 + wm command .t2 "test command" + wm command .t2 "new command" + wm command .t2 {} + destroy .t2 +} {} +test unixWm-15.5 {Tk_WmCmd procedure, "command" option} { + list [catch {wm command .t "a \{b"} msg] $msg +} {1 {unmatched open brace in list}} + +test unixWm-16.1 {Tk_WmCmd procedure, "deiconify" option} { + list [catch {wm deiconify .t 12} msg] $msg +} {1 {wrong # arguments: must be "wm deiconify window"}} +test unixWm-16.2 {Tk_WmCmd procedure, "deiconify" option} { + catch {destroy .icon} + toplevel .icon -width 50 -height 50 -bg red + wm iconwindow .t .icon + set result [list [catch {wm deiconify .icon} msg] $msg] + destroy .icon + set result +} {1 {can't deiconify .icon: it is an icon for .t}} +test unixWm-16.3 {Tk_WmCmd procedure, "deiconify" option} { + wm iconify .t + set result {} + lappend result [winfo ismapped .t] [wm state .t] + wm deiconify .t + lappend result [winfo ismapped .t] [wm state .t] +} {0 iconic 1 normal} + +test unixWm-17.1 {Tk_WmCmd procedure, "focusmodel" option} { + list [catch {wm focusmodel .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm focusmodel window ?active|passive?"}} +test unixWm-17.2 {Tk_WmCmd procedure, "focusmodel" option} { + list [catch {wm focusmodel .t bogus} msg] $msg +} {1 {bad argument "bogus": must be active or passive}} +test unixWm-17.3 {Tk_WmCmd procedure, "focusmodel" option} { + set result {} + 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 unixWm-18.1 {Tk_WmCmd procedure, "frame" option} { + list [catch {wm frame .t 12} msg] $msg +} {1 {wrong # arguments: must be "wm frame window"}} +test unixWm-18.2 {Tk_WmCmd procedure, "frame" option} nonPortable { + expr [wm frame .t] == [winfo id .t] +} {0} +test unixWm-18.3 {Tk_WmCmd procedure, "frame" option} nonPortable { + catch {destroy .t2} + toplevel .t2 + wm geom .t2 +0+0 + wm overrideredirect .t2 1 + update + set result [expr [wm frame .t2] == [winfo id .t2]] + destroy .t2 + set result +} {1} + +test unixWm-19.1 {Tk_WmCmd procedure, "geometry" option} { + list [catch {wm geometry .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm geometry window ?newGeometry?"}} +test unixWm-19.2 {Tk_WmCmd procedure, "geometry" option} nonPortable { + wm geometry .t -1+5 + update + wm geometry .t +} {100x50-1+5} +test unixWm-19.3 {Tk_WmCmd procedure, "geometry" option} nonPortable { + wm geometry .t +10-4 + update + wm geometry .t +} {100x50+10-4} +test unixWm-19.4 {Tk_WmCmd procedure, "geometry" option} nonPortable { + catch {destroy .t2} + toplevel .t2 + wm geom .t2 -5+10 + listbox .t2.l -width 30 -height 12 -setgrid 1 + pack .t2.l + update + set result [wm geometry .t2] + destroy .t2 + set result +} {30x12-5+10} +test unixWm-19.5 {Tk_WmCmd procedure, "geometry" option} nonPortable { + wm geometry .t 150x300+5+6 + update + set result {} + lappend result [wm geometry .t] + wm geometry .t {} + update + lappend result [wm geometry .t] +} {150x300+5+6 100x50+5+6} +test unixWm-19.6 {Tk_WmCmd procedure, "geometry" option} { + list [catch {wm geometry .t qrs} msg] $msg +} {1 {bad geometry specifier "qrs"}} + +test unixWm-20.1 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}} +test unixWm-20.2 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t 12 13 14 15 16} msg] $msg +} {1 {wrong # arguments: must be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}} +test unixWm-20.3 {Tk_WmCmd procedure, "grid" option} { + set result {} + lappend result [wm grid .t] + wm grid .t 5 6 20 10 + lappend result [wm grid .t] + wm grid .t {} {} {} {} + lappend result [wm grid .t] +} {{} {5 6 20 10} {}} +test unixWm-20.4 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t bad 10 11 12} msg] $msg +} {1 {expected integer but got "bad"}} +test unixWm-20.5 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t -1 11 12 13} msg] $msg +} {1 {baseWidth can't be < 0}} +test unixWm-20.6 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t 10 foo 12 13} msg] $msg +} {1 {expected integer but got "foo"}} +test unixWm-20.7 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t 10 -11 12 13} msg] $msg +} {1 {baseHeight can't be < 0}} +test unixWm-20.8 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t 10 11 bar 13} msg] $msg +} {1 {expected integer but got "bar"}} +test unixWm-20.9 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t 10 11 -2 13} msg] $msg +} {1 {widthInc can't be < 0}} +test unixWm-20.10 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t 10 11 12 bogus} msg] $msg +} {1 {expected integer but got "bogus"}} +test unixWm-20.11 {Tk_WmCmd procedure, "grid" option} { + list [catch {wm grid .t 10 11 12 -1} msg] $msg +} {1 {heightInc can't be < 0}} + +catch {destroy .t} +catch {destroy .icon} +toplevel .t -width 100 -height 50 +wm geom .t +0+0 +update + +test unixWm-21.1 {Tk_WmCmd procedure, "group" option} { + list [catch {wm group .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm group window ?pathName?"}} +test unixWm-21.2 {Tk_WmCmd procedure, "group" option} { + list [catch {wm group .t bogus} msg] $msg +} {1 {bad window path name "bogus"}} +test unixWm-21.3 {Tk_WmCmd procedure, "group" option} {unixOnly} { + set result {} + lappend result [wm group .t] + wm group .t . + set bit [format 0x%x [expr 0x40 & [lindex [testprop [testwrapper .t] \ + WM_HINTS] 0]]] + lappend result [wm group .t] $bit + wm group .t {} + set bit [format 0x%x [expr 0x40 & [lindex [testprop [testwrapper .t] \ + WM_HINTS] 0]]] + lappend result [wm group .t] $bit +} {{} . 0x40 {} 0x0} +test unixWm-21.4 {Tk_WmCmd procedure, "group" option, make window exist} {unixOnly} { + catch {destroy .t2} + toplevel .t2 + wm geom .t2 +0+0 + wm group .t .t2 + set hints [testprop [testwrapper .t] WM_HINTS] + set result [expr [testwrapper .t2] - [lindex $hints 8]] + destroy .t2 + set result +} {0} +test unixWm-21.5 {Tk_WmCmd procedure, "group" option, create leader wrapper} {unixOnly} { + catch {destroy .t2} + catch {destroy .t3} + toplevel .t2 -width 120 -height 300 + wm geometry .t2 +0+0 + toplevel .t3 -width 120 -height 300 + wm geometry .t2 +0+0 + set result [list [testwrapper .t2]] + wm group .t3 .t2 + lappend result [expr {[testwrapper .t2] == ""}] + destroy .t2 .t3 + set result +} {{} 0} + +test unixWm-22.1 {Tk_WmCmd procedure, "iconbitmap" option} { + list [catch {wm iconbitmap .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm iconbitmap window ?bitmap?"}} +test unixWm-22.2 {Tk_WmCmd procedure, "iconbitmap" option} {unixOnly} { + set result {} + lappend result [wm iconbitmap .t] + wm iconbitmap .t questhead + set bit [format 0x%x [expr 0x4 & [lindex [testprop [testwrapper .t] \ + WM_HINTS] 0]]] + lappend result [wm iconbitmap .t] $bit + wm iconbitmap .t {} + set bit [format 0x%x [expr 0x4 & [lindex [testprop [testwrapper .t] \ + WM_HINTS] 0]]] + lappend result [wm iconbitmap .t] $bit +} {{} questhead 0x4 {} 0x0} +test unixWm-22.3 {Tk_WmCmd procedure, "iconbitmap" option} { + list [catch {wm iconbitmap .t bad-bitmap} msg] $msg +} {1 {bitmap "bad-bitmap" not defined}} + +test unixWm-23.1 {Tk_WmCmd procedure, "iconify" option} { + list [catch {wm iconify .t 12} msg] $msg +} {1 {wrong # arguments: must be "wm iconify window"}} +test unixWm-23.2 {Tk_WmCmd procedure, "iconify" option} { + catch {destroy .t2} + toplevel .t2 + wm overrideredirect .t2 1 + set result [list [catch {wm iconify .t2} msg] $msg] + destroy .t2 + set result +} {1 {can't iconify ".t2": override-redirect flag is set}} +test unixWm-23.3 {Tk_WmCmd procedure, "iconify" option} { + catch {destroy .t2} + toplevel .t2 + wm geom .t2 +0+0 + wm transient .t2 .t + set result [list [catch {wm iconify .t2} msg] $msg] + destroy .t2 + set result +} {1 {can't iconify ".t2": it is a transient}} +test unixWm-23.4 {Tk_WmCmd procedure, "iconify" option} { + catch {destroy .t2} + toplevel .t2 + wm geom .t2 +0+0 + wm iconwindow .t .t2 + set result [list [catch {wm iconify .t2} msg] $msg] + destroy .t2 + set result +} {1 {can't iconify .t2: it is an icon for .t}} +test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} { + catch {destroy .t2} + toplevel .t2 + wm geom .t2 +0+0 + wm iconify .t2 + update + set result [winfo ismapped .t2] + destroy .t2 + set result +} {0} +test unixWm-23.6 {Tk_WmCmd procedure, "iconify" option} { + catch {destroy .t2} + toplevel .t2 + wm geom .t2 -0+0 + update + set result [winfo ismapped .t2] + wm iconify .t2 + lappend result [winfo ismapped .t2] + destroy .t2 + set result +} {1 0} + +test unixWm-24.1 {Tk_WmCmd procedure, "iconmask" option} { + list [catch {wm iconmask .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm iconmask window ?bitmap?"}} +test unixWm-24.2 {Tk_WmCmd procedure, "iconmask" option} {unixOnly} { + set result {} + lappend result [wm iconmask .t] + wm iconmask .t questhead + set bit [format 0x%x [expr 0x20 & [lindex [testprop [testwrapper .t] \ + WM_HINTS] 0]]] + lappend result [wm iconmask .t] $bit + wm iconmask .t {} + set bit [format 0x%x [expr 0x20 & [lindex [testprop [testwrapper .t] \ + WM_HINTS] 0]]] + lappend result [wm iconmask .t] $bit +} {{} questhead 0x20 {} 0x0} +test unixWm-24.3 {Tk_WmCmd procedure, "iconmask" option} { + list [catch {wm iconmask .t bogus} msg] $msg +} {1 {bitmap "bogus" not defined}} + +test unixWm-25.1 {Tk_WmCmd procedure, "iconname" option} { + list [catch {wm icon .t} msg] $msg +} {1 {unknown or ambiguous option "icon": must be aspect, client, command, deiconify, focusmodel, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconposition, iconwindow, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, state, title, transient, or withdraw}} +test unixWm-25.2 {Tk_WmCmd procedure, "iconname" option} { + list [catch {wm iconname .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm iconname window ?newName?"}} +test unixWm-25.3 {Tk_WmCmd procedure, "iconname" option} {unixOnly} { + set result {} + lappend result [wm iconname .t] + wm iconname .t test_name + lappend result [wm iconname .t] [testprop [testwrapper .t] WM_ICON_NAME] + wm iconname .t {} + lappend result [wm iconname .t] [testprop [testwrapper .t] WM_ICON_NAME] +} {{} test_name test_name {} {}} + +test unixWm-26.1 {Tk_WmCmd procedure, "iconposition" option} { + list [catch {wm iconposition .t 12} msg] $msg +} {1 {wrong # arguments: must be "wm iconposition window ?x y?"}} +test unixWm-26.2 {Tk_WmCmd procedure, "iconposition" option} { + list [catch {wm iconposition .t 12 13 14} msg] $msg +} {1 {wrong # arguments: must be "wm iconposition window ?x y?"}} +test unixWm-26.3 {Tk_WmCmd procedure, "iconposition" option} {unixOnly} { + set result {} + lappend result [wm iconposition .t] + wm iconposition .t 10 15 + set prop [testprop [testwrapper .t] WM_HINTS] + lappend result [wm iconposition .t] [lindex $prop 5] [lindex $prop 6] + lappend result [format 0x%x [expr 0x10 & [lindex $prop 0]]] + wm iconposition .t {} {} + set bit [format 0x%x [expr 0x10 & [lindex [testprop [testwrapper .t] \ + WM_HINTS] 0]]] + lappend result [wm iconposition .t] $bit +} {{} {10 15} 0xa 0xf 0x10 {} 0x0} +test unixWm-26.4 {Tk_WmCmd procedure, "iconposition" option} { + list [catch {wm iconposition .t bad 13} msg] $msg +} {1 {expected integer but got "bad"}} +test unixWm-26.5 {Tk_WmCmd procedure, "iconposition" option} { + list [catch {wm iconposition .t 13 lousy} msg] $msg +} {1 {expected integer but got "lousy"}} + +test unixWm-27.1 {Tk_WmCmd procedure, "iconwindow" option} { + list [catch {wm iconwindow .t 12 13} msg] $msg +} {1 {wrong # arguments: must be "wm iconwindow window ?pathName?"}} +test unixWm-27.2 {Tk_WmCmd procedure, "iconwindow" option} {unixOnly} { + catch {destroy .icon} + toplevel .icon -width 50 -height 50 -bg green + set result {} + lappend result [wm iconwindow .t] + wm iconwindow .t .icon + set prop [testprop [testwrapper .t] WM_HINTS] + lappend result [wm iconwindow .t] [wm state .icon] + lappend result [format 0x%x [expr 0x8 & [lindex $prop 0]]] + lappend result [expr [testwrapper .icon] == [lindex $prop 4]] + wm iconwindow .t {} + set bit [format 0x%x [expr 0x8 & [lindex [testprop [testwrapper .t] \ + WM_HINTS] 0]]] + lappend result [wm iconwindow .t] [wm state .icon] $bit + destroy .icon + set result +} {{} .icon icon 0x8 1 {} withdrawn 0x0} +test unixWm-27.3 {Tk_WmCmd procedure, "iconwindow" option} { + list [catch {wm iconwindow .t bogus} msg] $msg +} {1 {bad window path name "bogus"}} +test unixWm-27.4 {Tk_WmCmd procedure, "iconwindow" option} { + catch {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} { + catch {destroy .icon} + 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}} +test unixWm-27.6 {Tk_WmCmd procedure, "iconwindow" option, changing icons} { + catch {destroy .icon} + catch {destroy .icon2} + toplevel .icon -width 50 -height 50 -bg green + toplevel .icon2 -width 50 -height 50 -bg red + set result {} + wm iconwindow .t .icon + lappend result [wm state .icon] [wm state .icon2] + wm iconwindow .t .icon2 + lappend result [wm state .icon] [wm state .icon2] + destroy .icon .icon2 + set result +} {icon normal withdrawn icon} +test unixWm-27.7 {Tk_WmCmd procedure, "iconwindow" option, withdrawing icon} { + catch {destroy .icon} + toplevel .icon -width 50 -height 50 -bg green + wm geometry .icon +0+0 + update + set result {} + lappend result [wm state .icon] [winfo viewable .icon] + wm iconwindow .t .icon + lappend result [wm state .icon] [winfo viewable .icon] + destroy .icon + set result +} {normal 1 icon 0} + +test unixWm-28.1 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize} msg] $msg +} {1 {wrong # args: should be "wm option window ?arg ...?"}} +test unixWm-28.2 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize . a} msg] $msg +} {1 {wrong # arguments: must be "wm maxsize window ?width height?"}} +test unixWm-28.3 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize . a b c} msg] $msg +} {1 {wrong # arguments: must be "wm maxsize window ?width height?"}} +test unixWm-28.4 {Tk_WmCmd procedure, "maxsize" option} {nonPortable} { + wm maxsize .t +} {1137 870} +test unixWm-28.5 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize . x 100} msg] $msg +} {1 {expected integer but got "x"}} +test unixWm-28.6 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize . 100 bogus} msg] $msg +} {1 {expected integer but got "bogus"}} +test unixWm-28.7 {Tk_WmCmd procedure, "maxsize" option} { + wm maxsize .t 200 150 + wm maxsize .t +} {200 150} +test unixWm-28.8 {Tk_WmCmd procedure, "maxsize" option} {nonPortable} { + # Not portable, because some window managers let applications override + # minsize and maxsize. + + wm maxsize .t 200 150 + wm geom .t 300x200 + update + list [winfo width .t] [winfo height .t] +} {200 150} + +catch {destroy .t} +catch {destroy .icon} +toplevel .t -width 100 -height 50 +wm geom .t +0+0 +update + +test unixWm-29.1 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize} msg] $msg +} {1 {wrong # args: should be "wm option window ?arg ...?"}} +test unixWm-29.2 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize . a} msg] $msg +} {1 {wrong # arguments: must be "wm minsize window ?width height?"}} +test unixWm-29.3 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize . a b c} msg] $msg +} {1 {wrong # arguments: must be "wm minsize window ?width height?"}} +test unixWm-29.4 {Tk_WmCmd procedure, "minsize" option} { + wm minsize .t +} {1 1} +test unixWm-29.5 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize . x 100} msg] $msg +} {1 {expected integer but got "x"}} +test unixWm-29.6 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize . 100 bogus} msg] $msg +} {1 {expected integer but got "bogus"}} +test unixWm-29.7 {Tk_WmCmd procedure, "minsize" option} { + wm minsize .t 200 150 + wm minsize .t +} {200 150} +test unixWm-29.8 {Tk_WmCmd procedure, "minsize" option} {nonPortable} { + # Not portable, because some window managers let applications override + # minsize and maxsize. + + wm minsize .t 150 100 + wm geom .t 50x50 + update + list [winfo width .t] [winfo height .t] +} {150 100} + +catch {destroy .t} +catch {destroy .icon} +toplevel .t -width 100 -height 50 +wm geom .t +0+0 +update + +test unixWm-30.1 {Tk_WmCmd procedure, "overrideredirect" option} { + list [catch {wm overrideredirect .t 1 2} msg] $msg +} {1 {wrong # arguments: must be "wm overrideredirect window ?boolean?"}} +test unixWm-30.2 {Tk_WmCmd procedure, "overrideredirect" option} { + list [catch {wm overrideredirect .t boo} msg] $msg +} {1 {expected boolean value but got "boo"}} +test unixWm-30.3 {Tk_WmCmd procedure, "overrideredirect" option} { + set result {} + 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} + +test unixWm-31.1 {Tk_WmCmd procedure, "positionfrom" option} { + list [catch {wm positionfrom .t 1 2} msg] $msg +} {1 {wrong # arguments: must be "wm positionfrom window ?user/program?"}} +test unixWm-31.2 {Tk_WmCmd procedure, "positionfrom" option} {unixOnly} { + set result {} + lappend result [wm positionfrom .t] + wm positionfrom .t program + update + set bit [format 0x%x [expr 0x5 & [lindex [testprop [testwrapper .t] \ + WM_NORMAL_HINTS] 0]]] + lappend result [wm positionfrom .t] $bit + wm positionfrom .t user + update + set bit [format 0x%x [expr 0x5 & [lindex [testprop [testwrapper .t] \ + WM_NORMAL_HINTS] 0]]] + lappend result [wm positionfrom .t] $bit +} {user program 0x4 user 0x1} +test unixWm-31.3 {Tk_WmCmd procedure, "positionfrom" option} { + list [catch {wm positionfrom .t none} msg] $msg +} {1 {bad argument "none": must be program or user}} + +test unixWm-32.1 {Tk_WmCmd procedure, "protocol" option} { + list [catch {wm protocol .t 1 2 3} msg] $msg +} {1 {wrong # arguments: must be "wm protocol window ?name? ?command?"}} +test unixWm-32.2 {Tk_WmCmd procedure, "protocol" option} { + wm protocol .t {foo a} {a b c} + wm protocol .t bar {test script for bar} + set result [wm protocol .t] + wm protocol .t {foo a} {} + wm protocol .t bar {} + set result +} {bar {foo a}} +test unixWm-32.3 {Tk_WmCmd procedure, "protocol" option} {unixOnly} { + set result {} + lappend result [wm protocol .t] + set x {} + foreach i [testprop [testwrapper .t] WM_PROTOCOLS] { + lappend x [winfo atomname $i] + } + lappend result $x + wm protocol .t foo {test script} + wm protocol .t bar {test script} + set x {} + foreach i [testprop [testwrapper .t] WM_PROTOCOLS] { + lappend x [winfo atomname $i] + } + lappend result [wm protocol .t] $x + wm protocol .t foo {} + wm protocol .t bar {} + set x {} + foreach i [testprop [testwrapper .t] WM_PROTOCOLS] { + lappend x [winfo atomname $i] + } + lappend result [wm protocol .t] $x +} {{} WM_DELETE_WINDOW {bar foo} {WM_DELETE_WINDOW bar foo} {} WM_DELETE_WINDOW} +test unixWm-32.4 {Tk_WmCmd procedure, "protocol" option} { + set result {} + 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 unixWm-32.5 {Tk_WmCmd procedure, "protocol" option} { + wm protocol .t foo {a b c} + wm protocol .t foo {test script} + set result [wm protocol .t foo] + wm protocol .t foo {} + set result +} {test script} + +test unixWm-33.1 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable . a} msg] $msg +} {1 {wrong # arguments: must be "wm resizable window ?width height?"}} +test unixWm-33.2 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable . a b c} msg] $msg +} {1 {wrong # arguments: must be "wm resizable window ?width height?"}} +test unixWm-33.3 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable .foo a b c} msg] $msg +} {1 {bad window path name ".foo"}} +test unixWm-33.4 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable . x 1} msg] $msg +} {1 {expected boolean value but got "x"}} +test unixWm-33.5 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable . 0 gorp} msg] $msg +} {1 {expected boolean value but got "gorp"}} +test unixWm-33.6 {Tk_WmCmd procedure, "resizable" option} { + catch {destroy .t2} + toplevel .t2 -width 200 -height 100 + wm geom .t2 +0+0 + set result "" + lappend result [wm resizable .t2] + wm resizable .t2 1 0 + lappend result [wm resizable .t2] + wm resizable .t2 no off + lappend result [wm resizable .t2] + wm resizable .t2 false true + lappend result [wm resizable .t2] + destroy .t2 + set result +} {{1 1} {1 0} {0 0} {0 1}} + +test unixWm-34.1 {Tk_WmCmd procedure, "sizefrom" option} { + list [catch {wm sizefrom .t 1 2} msg] $msg +} {1 {wrong # arguments: must be "wm sizefrom window ?user|program?"}} +test unixWm-34.2 {Tk_WmCmd procedure, "sizefrom" option} {unixOnly} { + set result {} + lappend result [wm sizefrom .t] + wm sizefrom .t program + update + set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \ + WM_NORMAL_HINTS] 0]]] + lappend result [wm sizefrom .t] $bit + wm sizefrom .t user + update + set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \ + WM_NORMAL_HINTS] 0]]] + lappend result [wm sizefrom .t] $bit +} {{} program 0x8 user 0x2} +test unixWm-34.3 {Tk_WmCmd procedure, "sizefrom" option} { + list [catch {wm sizefrom .t none} msg] $msg +} {1 {bad argument "none": must be program or user}} + +test unixWm-35.1 {Tk_WmCmd procedure, "state" option} { + list [catch {wm state .t 1} msg] $msg +} {1 {wrong # arguments: must be "wm state window"}} +test unixWm-35.2 {Tk_WmCmd procedure, "state" option} { + set result {} + catch {destroy .t2} + toplevel .t2 -width 120 -height 300 + wm geometry .t2 +0+0 + lappend result [wm state .t2] + update + lappend result [wm state .t2] + wm withdraw .t2 + lappend result [wm state .t2] + wm iconify .t2 + lappend result [wm state .t2] + wm deiconify .t2 + lappend result [wm state .t2] + destroy .t2 + set result +} {normal normal withdrawn iconic normal} + +test unixWm-36.1 {Tk_WmCmd procedure, "title" option} { + list [catch {wm title .t 1 2} msg] $msg +} {1 {wrong # arguments: must be "wm title window ?newTitle?"}} +test unixWm-36.2 {Tk_WmCmd procedure, "title" option} {unixOnly} { + set result {} + lappend result [wm title .t] [testprop [testwrapper .t] WM_NAME] + wm title .t "Test window" + set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \ + WM_NORMAL_HINTS] 0]]] + lappend result [wm title .t] [testprop [testwrapper .t] WM_NAME] +} {t t {Test window} {Test window}} + +test unixWm-37.1 {Tk_WmCmd procedure, "transient" option} { + list [catch {wm transient .t 1 2} msg] $msg +} {1 {wrong # arguments: must be "wm transient window ?master?"}} +test unixWm-37.2 {Tk_WmCmd procedure, "transient" option} { + list [catch {wm transient .t foo} msg] $msg +} {1 {bad window path name "foo"}} +test unixWm-37.3 {Tk_WmCmd procedure, "transient" option} {unixOnly} { + set result {} + catch {destroy .t2} + toplevel .t2 -width 120 -height 300 + wm geometry .t2 +0+0 + update + lappend result [wm transient .t2] \ + [testprop [testwrapper .t2] WM_TRANSIENT_FOR] + wm transient .t2 .t + set transient [testprop [testwrapper .t2] WM_TRANSIENT_FOR] + lappend result [wm transient .t2] [expr [testwrapper .t] - $transient] + wm transient .t2 {} + lappend result [wm transient .t2] \ + [testprop [testwrapper .t2] WM_TRANSIENT_FOR] + destroy .t2 + set result +} {{} {} .t 0 {} 0x0} +test unixWm-37.4 {Tk_WmCmd procedure, "transient" option, create master wrapper} {unixOnly} { + catch {destroy .t2} + catch {destroy .t3} + toplevel .t2 -width 120 -height 300 + wm geometry .t2 +0+0 + toplevel .t3 -width 120 -height 300 + wm geometry .t2 +0+0 + set result [list [testwrapper .t2]] + wm transient .t3 .t2 + lappend result [expr {[testwrapper .t2] == ""}] + destroy .t2 .t3 + set result +} {{} 0} + +test unixWm-38.1 {Tk_WmCmd procedure, "withdraw" option} { + list [catch {wm withdraw .t 1} msg] $msg +} {1 {wrong # arguments: must be "wm withdraw window"}} +test unixWm-38.2 {Tk_WmCmd procedure, "withdraw" option} { + catch {destroy .t2} + toplevel .t2 -width 120 -height 300 + wm geometry .t2 +0+0 + 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}} +test unixWm-38.3 {Tk_WmCmd procedure, "withdraw" option} { + set result {} + 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} + +test unixWm-39.1 {Tk_WmCmd procedure, miscellaneous} { + list [catch {wm unknown .t} msg] $msg +} {1 {unknown or ambiguous option "unknown": must be aspect, client, command, deiconify, focusmodel, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconposition, iconwindow, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, state, title, transient, or withdraw}} + +catch {destroy .t} +catch {destroy .icon} + +test unixWm-40.1 {Tk_SetGrid procedure, set grid dimensions before turning on grid} {nonPortable} { + catch {destroy .t} + toplevel .t + wm geometry .t 30x10+0+0 + listbox .t.l -height 20 -width 20 -setgrid 1 + pack .t.l -fill both -expand 1 + update + wm geometry .t +} {30x10+0+0} +test unixWm-40.2 {Tk_SetGrid procedure, turning on grid when dimensions already set} { + catch {destroy .t} + toplevel .t + wm geometry .t 200x100+0+0 + listbox .t.l -height 20 -width 20 + pack .t.l -fill both -expand 1 + update + .t.l configure -setgrid 1 + update + wm geometry .t +} {20x20+0+0} + +test unixWm-41.1 {ConfigureEvent procedure, internally generated size changes} { + catch {destroy .t} + toplevel .t -width 400 -height 150 + wm geometry .t +0+0 + tkwait visibility .t + set result {} + lappend result [winfo width .t] [winfo height .t] + .t configure -width 200 -height 300 + sleep 500 + lappend result [winfo width .t] [winfo height .t] +} {400 150 200 300} +test unixWm-41.2 {ConfigureEvent procedure, menubars} {unixOnly} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + wm geom .t +0+0 + update + set x [winfo rootx .t] + set y [winfo rooty .t] + frame .t.m -bd 2 -relief raised -height 20 + testmenubar window .t .t.m + update + set result {} + bind .t <Configure> { + if {"%W" == ".t"} { + lappend result "%W: %wx%h" + } + } + bind .t.m <Configure> {lappend result "%W: %wx%h"} + wm geometry .t 200x300 + update + lappend result [expr [winfo rootx .t.m] - $x] \ + [expr [winfo rooty .t.m] - $y] \ + [winfo width .t.m] [winfo height .t.m] \ + [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y] \ + [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} { + catch {destroy .t} + toplevel .t -width 400 -height 150 + wm geometry .t +0+0 + tkwait visibility .t + set result {no event} + bind .t <Configure> {set result "configured: %w %h"} + wm geometry .t +10+20 + update + set result +} {configured: 400 150} +test unixWm-41.4 {ConfigureEvent procedure, synthesized Configure events} { + catch {destroy .t} + toplevel .t -width 400 -height 150 + wm geometry .t +0+0 + tkwait visibility .t + set result {no event} + bind .t <Configure> {set result "configured: %w %h"} + wm geometry .t 130x200 + update + set result +} {configured: 130 200} + +# No tests for ReparentEvent or ComputeReparentGeometry; I can't figure +# out how to exercise these procedures reliably. + +test unixWm-42.1 {WrapperEventProc procedure, map and unmap events} { + catch {destroy .t} + toplevel .t -width 400 -height 150 + wm geometry .t +0+0 + tkwait visibility .t + set result {} + bind .t <Map> {set x "mapped"} + bind .t <Unmap> {set x "unmapped"} + set x {no event} + wm iconify .t + lappend result $x [winfo ismapped .t] + set x {no event} + wm deiconify .t + lappend result $x [winfo ismapped .t] +} {unmapped 0 mapped 1} + +test unixWm-43.1 {TopLevelReqProc procedure, embedded in same process} { + catch {destroy .t} + toplevel .t -width 200 -height 200 + wm geom .t +0+0 + frame .t.f -container 1 -bd 2 -relief raised + place .t.f -x 20 -y 10 + tkwait visibility .t.f + toplevel .t2 -use [winfo id .t.f] -width 30 -height 20 -bg blue + tkwait visibility .t2 + set result {} + .t2 configure -width 70 -height 120 + update + lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f] + lappend result [winfo width .t2] [winfo height .t2] + # destroy .t2 + set result +} {70 120 70 120} +test unixWm-43.2 {TopLevelReqProc procedure, resize causes window to move} \ + {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 200 + wm geom .t +0+0 + update + wm geom .t -0-0 + update + set x [winfo x .t] + set y [winfo y .t] + .t configure -width 300 -height 150 + update + list [expr [winfo x .t] - $x] [expr [winfo y .t] - $y] \ + [winfo width .t] [winfo height .t] +} {-100 50 300 150} + +test unixWm-44.1 {UpdateGeometryInfo procedure, width/height computation} { + catch {destroy .t} + toplevel .t -width 100 -height 200 + wm geometry .t +30+40 + wm overrideredirect .t 1 + tkwait visibility .t + .t configure -width 180 -height 20 + update + list [winfo width .t] [winfo height .t] +} {180 20} +test unixWm-44.2 {UpdateGeometryInfo procedure, width/height computation} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm grid .t 5 4 10 12 + wm geometry .t +30+40 + wm overrideredirect .t 1 + tkwait visibility .t + wm geometry .t 10x2 + update + list [winfo width .t] [winfo height .t] +} {130 36} +test unixWm-44.3 {UpdateGeometryInfo procedure, width/height computation} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm grid .t 5 4 10 12 + wm geometry .t +30+40 + wm overrideredirect .t 1 + tkwait visibility .t + wm geometry .t 1x10 + update + list [winfo width .t] [winfo height .t] +} {40 132} +test unixWm-44.4 {UpdateGeometryInfo procedure, width/height computation} { + catch {destroy .t} + toplevel .t -width 100 -height 200 + wm geometry .t +30+40 + wm overrideredirect .t 1 + tkwait visibility .t + wm geometry .t 300x150 + update + list [winfo width .t] [winfo height .t] +} {300 150} +test unixWm-44.5 {UpdateGeometryInfo procedure, negative width} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm grid .t 18 7 10 12 + wm geometry .t +30+40 + wm overrideredirect .t 1 + tkwait visibility .t + wm geometry .t 5x8 + update + list [winfo width .t] [winfo height .t] +} {1 72} +test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm grid .t 18 7 10 12 + wm geometry .t +30+40 + wm overrideredirect .t 1 + tkwait visibility .t + wm geometry .t 20x1 + update + list [winfo width .t] [winfo height .t] +} {100 1} +test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm geometry .t +5-10 + wm overrideredirect .t 1 + tkwait visibility .t + list [winfo x .t] [winfo y .t] +} "5 [expr [winfo screenheight .t] - 70]" +test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm geometry .t -30+2 + wm overrideredirect .t 1 + tkwait visibility .t + list [winfo x .t] [winfo y .t] +} "[expr [winfo screenwidth .t] - 110] 2" +test unixWm-44.9 {UpdateGeometryInfo procedure, updating fixed dimensions} {unixOnly} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm resizable .t 0 0 + wm geometry .t +0+0 + tkwait visibility .t + .t configure -width 180 -height 20 + update + set property [testprop [testwrapper .t] WM_NORMAL_HINTS] + list [expr [lindex $property 5]] [expr [lindex $property 6]] \ + [expr [lindex $property 7]] [expr [lindex $property 8]] +} {180 20 180 20} +test unixWm-44.10 {UpdateGeometryInfo procedure, menubar changing} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm resizable .t 0 0 + wm geometry .t +0+0 + tkwait visibility .t + .t configure -width 180 -height 50 + frame .t.m -bd 2 -relief raised -width 100 -height 50 + testmenubar window .t .t.m + update + .t configure -height 70 + .t.m configure -height 30 + list [update] [destroy .t] +} {{} {}} + +test unixWm-45.1 {UpdateSizeHints procedure, grid information} {unixOnly} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm grid .t 6 10 10 5 + wm minsize .t 2 4 + wm maxsize .t 30 40 + wm geometry .t +0+0 + tkwait visibility .t + set property [testprop [testwrapper .t] WM_NORMAL_HINTS] + list [expr [lindex $property 5]] [expr [lindex $property 6]] \ + [expr [lindex $property 7]] [expr [lindex $property 8]] \ + [expr [lindex $property 9]] [expr [lindex $property 10]] +} {40 30 320 210 10 5} +test unixWm-45.2 {UpdateSizeHints procedure} {unixOnly} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + wm minsize .t 30 40 + wm maxsize .t 200 500 + wm geometry .t +0+0 + tkwait visibility .t + set property [testprop [testwrapper .t] WM_NORMAL_HINTS] + list [expr [lindex $property 5]] [expr [lindex $property 6]] \ + [expr [lindex $property 7]] [expr [lindex $property 8]] \ + [expr [lindex $property 9]] [expr [lindex $property 10]] +} {30 40 200 500 1 1} +test unixWm-45.3 {UpdateSizeHints procedure, grid with menu} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + frame .t.menu -height 23 -width 50 + testmenubar window .t .t.menu + wm grid .t 6 10 10 5 + wm minsize .t 2 4 + wm maxsize .t 30 40 + wm geometry .t +0+0 + tkwait visibility .t + set property [testprop [testwrapper .t] WM_NORMAL_HINTS] + list [winfo height .t] \ + [expr [lindex $property 5]] [expr [lindex $property 6]] \ + [expr [lindex $property 7]] [expr [lindex $property 8]] \ + [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} { + catch {destroy .t} + toplevel .t -width 80 -height 60 + frame .t.menu -height 23 -width 50 + testmenubar window .t .t.menu + wm resizable .t 0 0 + wm geometry .t +0+0 + tkwait visibility .t + set property [testprop [testwrapper .t] WM_NORMAL_HINTS] + list [winfo height .t] \ + [expr [lindex $property 5]] [expr [lindex $property 6]] \ + [expr [lindex $property 7]] [expr [lindex $property 8]] \ + [expr [lindex $property 9]] [expr [lindex $property 10]] +} {60 80 83 80 83 1 1} + +# I don't know how to test WaitForConfigureNotify. + +test unixWm-46.1 {WaitForEvent procedure, use of modal timeout} { + catch {destroy .t} + toplevel .t -width 200 -height 200 + wm geom .t +0+0 + update + wm iconify .t + set x no + after 0 {set x yes} + wm deiconify .t + set result $x + update + list $result $x +} {no yes} + +test unixWm-47.1 {WaitRestrictProc procedure} { + catch {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 + wm geometry .t +0+0 + tkwait visibility .t + set result {} + bind .t.f <Configure> {lappend result {configure on .t.f}} + bind .t <Map> {lappend result {map on .t}} + bind .t <Unmap> {lappend result {unmap on .t}; bind .t <Unmap> {}} + bind .t <Button> {lappend result {button %b on .t}} + event generate .t.f <Configure> -when tail + event generate .t <Configure> -when tail + event generate .t <Button> -button 3 -when tail + event generate .t <Map> -when tail + lappend result iconify + wm iconify .t + lappend result done + update + set result +} {iconify {unmap on .t} done {configure on .t.f} {button 3 on .t} {map on .t}} + +# I don't know how to test WaitTimeoutProc, WaitForMapNotify, or UpdateHints. + +catch {destroy .t} +toplevel .t -width 300 -height 200 +wm geometry .t +0+0 +tkwait visibility .t + +test unixWm-48.1 {ParseGeometry procedure} { + wm geometry .t =100x120 + update + list [winfo width .t] [winfo height .t] +} {100 120} +test unixWm-48.2 {ParseGeometry procedure} { + list [catch {wm geometry .t =10zx120} msg] $msg +} {1 {bad geometry specifier "=10zx120"}} +test unixWm-48.3 {ParseGeometry procedure} { + list [catch {wm geometry .t x120} msg] $msg +} {1 {bad geometry specifier "x120"}} +test unixWm-48.4 {ParseGeometry procedure} { + list [catch {wm geometry .t =100x120a} msg] $msg +} {1 {bad geometry specifier "=100x120a"}} +test unixWm-48.5 {ParseGeometry procedure} { + list [catch {wm geometry .t z} msg] $msg +} {1 {bad geometry specifier "z"}} +test unixWm-48.6 {ParseGeometry procedure} { + list [catch {wm geometry .t +20&} msg] $msg +} {1 {bad geometry specifier "+20&"}} +test unixWm-48.7 {ParseGeometry procedure} { + list [catch {wm geometry .t +-} msg] $msg +} {1 {bad geometry specifier "+-"}} +test unixWm-48.8 {ParseGeometry procedure} { + list [catch {wm geometry .t +20a} msg] $msg +} {1 {bad geometry specifier "+20a"}} +test unixWm-48.9 {ParseGeometry procedure} { + list [catch {wm geometry .t +20-} msg] $msg +} {1 {bad geometry specifier "+20-"}} +test unixWm-48.10 {ParseGeometry procedure} { + list [catch {wm geometry .t +20+10z} msg] $msg +} {1 {bad geometry specifier "+20+10z"}} +test unixWm-48.11 {ParseGeometry procedure} { + catch {wm geometry .t +-10+20} +} {0} +test unixWm-48.12 {ParseGeometry procedure} { + catch {wm geometry .t +30+-10} +} {0} +test unixWm-48.13 {ParseGeometry procedure, resize causes window to move} { + catch {destroy .t} + toplevel .t -width 200 -height 200 + wm geom .t +0+0 + update + wm geom .t -0-0 + update + set x [winfo x .t] + set y [winfo y .t] + wm geometry .t 150x300 + update + list [expr [winfo x .t] - $x] [expr [winfo y .t] - $y] \ + [winfo width .t] [winfo height .t] +} {50 -100 150 300} + +test unixWm-49.1 {Tk_GetRootCoords procedure} { + catch {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 + frame .t.f.f -width 20 -height 20 -bd 2 -relief raised + place .t.f.f -x 10 -y 20 + wm overrideredirect .t 1 + wm geometry .t +40+50 + tkwait visibility .t + list [winfo rootx .t.f.f] [winfo rooty .t.f.f] +} {202 192} +test unixWm-49.2 {Tk_GetRootCoords procedure, menubars} {unixOnly} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + wm geom .t +0+0 + update + set x [winfo rootx .t] + set y [winfo rooty .t] + frame .t.m -bd 2 -relief raised -width 100 -height 30 + frame .t.m.f -width 20 -height 10 -bd 2 -relief raised + place .t.m.f -x 50 -y 5 + frame .t.f -width 20 -height 30 -bd 2 -relief raised + place .t.f -x 10 -y 30 + testmenubar window .t .t.m + update + list [expr [winfo rootx .t.m.f] - $x] [expr [winfo rooty .t.m.f] - $y] \ + [expr [winfo rootx .t.f] - $x] [expr [winfo rooty .t.f] - $y] +} {52 7 12 62} + +foreach w [winfo children .] { + catch {destroy $w} +} +wm iconify . +test unixWm-50.1 {Tk_CoordsToWindow procedure, finding a toplevel, x-coords} { + eval destroy [winfo children .] + toplevel .t -width 300 -height 400 -bg green + wm geom .t +40+0 + tkwait visibility .t + toplevel .t2 -width 100 -height 80 -bg red + wm geom .t2 +140+200 + tkwait visibility .t2 + raise .t2 + set x [winfo rootx .t] + set y [winfo rooty .t] + list [winfo containing [expr $x - 30] [expr $y + 250]] \ + [winfo containing [expr $x - 1] [expr $y + 250]] \ + [winfo containing $x [expr $y + 250]] \ + [winfo containing [expr $x + 99] [expr $y + 250]] \ + [winfo containing [expr $x + 100] [expr $y + 250]] \ + [winfo containing [expr $x + 199] [expr $y + 250]] \ + [winfo containing [expr $x + 200] [expr $y + 250]] \ + [winfo containing [expr $x + 220] [expr $y + 250]] +} {{} {} .t {} .t2 .t2 {} .t} +test unixWm-50.2 {Tk_CoordsToWindow procedure, finding a toplevel, y-coords and overrideredirect} { + eval destroy [winfo children .] + toplevel .t -width 300 -height 400 -bg yellow + wm geom .t +0+50 + tkwait visibility .t + toplevel .t2 -width 100 -height 80 -bg blue + wm overrideredirect .t2 1 + wm geom .t2 +100+200 + tkwait visibility .t2 + raise .t2 + set x [winfo rootx .t] + set y [winfo rooty .t] + set y2 [winfo rooty .t2] + list [winfo containing [expr $x +150] 10] \ + [winfo containing [expr $x +150] [expr $y - 1]] \ + [winfo containing [expr $x +150] $y] \ + [winfo containing [expr $x +150] [expr $y2 - 1]] \ + [winfo containing [expr $x +150] $y2] \ + [winfo containing [expr $x +150] [expr $y2 + 79]] \ + [winfo containing [expr $x +150] [expr $y2 + 80]] \ + [winfo containing [expr $x +150] [expr $y + 450]] +} {{} {} .t .t .t2 .t2 .t {}} +test unixWm-50.3 {Tk_CoordsToWindow procedure, finding a toplevel with embedding} { + eval destroy [winfo children .] + toplevel .t -width 300 -height 400 -bg blue + wm geom .t +0+50 + frame .t.f -container 1 + place .t.f -x 150 -y 50 + tkwait visibility .t.f + setupbg + dobg " + wm withdraw . + toplevel .x -width 100 -height 80 -use [winfo id .t.f] -bg yellow + tkwait visibility .x" + set result [dobg { + set x [winfo rootx .x] + set y [winfo rooty .x] + list [winfo containing [expr $x - 1] [expr $y + 50]] \ + [winfo containing $x [expr $y +50]] + }] + set x [winfo rootx .t] + set y [winfo rooty .t] + lappend result [winfo containing [expr $x + 200] [expr $y + 49]] \ + [winfo containing [expr $x + 200] [expr $y +50]] +} {{} .x .t .t.f} +cleanupbg +test unixWm-50.4 {Tk_CoordsToWindow procedure, window in other application} { + catch {destroy .t} + catch {interp delete slave} + toplevel .t -width 200 -height 200 -bg green + wm geometry .t +0+0 + tkwait visibility .t + interp create slave + load {} tk slave + slave eval {wm geometry . 200x200+0+0; tkwait visibility .} + set result [list [winfo containing 100 100] \ + [slave eval {winfo containing 100 100}]] + interp delete slave + set result +} {{} .} +test unixWm-50.5 {Tk_CoordsToWindow procedure, handling menubars} {unixOnly} { + eval destroy [winfo children .] + toplevel .t -width 300 -height 400 -bd 2 -relief raised + frame .t.f -width 150 -height 120 -bg green + place .t.f -x 10 -y 150 + wm geom .t +0+50 + frame .t.menu -width 100 -height 30 -bd 2 -relief raised + frame .t.menu.f -width 40 -height 20 -bg purple + place .t.menu.f -x 30 -y 10 + testmenubar window .t .t.menu + tkwait visibility .t.menu + update + set x [winfo rootx .t] + set y [winfo rooty .t] + list [winfo containing $x [expr $y - 31]] \ + [winfo containing $x [expr $y - 30]] \ + [winfo containing [expr $x + 50] [expr $y - 19]] \ + [winfo containing [expr $x + 50] [expr $y - 18]] \ + [winfo containing [expr $x + 50] $y] \ + [winfo containing [expr $x + 11] [expr $y + 152]] \ + [winfo containing [expr $x + 12] [expr $y + 152]] +} {{} .t.menu .t.menu .t.menu.f .t .t .t.f} +test unixWm-50.6 {Tk_CoordsToWindow procedure, embedding within one app.} { + eval destroy [winfo children .] + toplevel .t -width 300 -height 400 -bg orange + wm geom .t +0+50 + frame .t.f -container 1 + place .t.f -x 150 -y 50 + tkwait visibility .t.f + toplevel .t2 -width 100 -height 80 -bg green -use [winfo id .t.f] + tkwait visibility .t2 + update + set x [winfo rootx .t] + set y [winfo rooty .t] + list [winfo containing [expr $x +149] [expr $y + 80]] \ + [winfo containing [expr $x +150] [expr $y +80]] \ + [winfo containing [expr $x +249] [expr $y +80]] \ + [winfo containing [expr $x +250] [expr $y +80]] +} {.t .t2 .t2 .t} +test unixWm-50.7 {Tk_CoordsToWindow procedure, more basics} { + catch {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 + place .t.f -x 100 -y 100 + frame .t.f.f -width 100 -height 200 -bd 2 -relief raised + place .t.f.f -x 0 -y 100 + tkwait visibility .t.f.f + set x [expr [winfo rootx .t] + 150] + set y [winfo rooty .t] + list [winfo containing $x [expr $y + 50]] \ + [winfo containing $x [expr $y + 150]] \ + [winfo containing $x [expr $y + 250]] \ + [winfo containing $x [expr $y + 350]] \ + [winfo containing $x [expr $y + 450]] +} {.t .t.f .t.f.f .t {}} +test unixWm-50.8 {Tk_CoordsToWindow procedure, more basics} { + catch {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 + place .t.f -x 100 -y 100 + frame .t.f.f -width 200 -height 100 -bd 2 -relief raised + place .t.f.f -x 100 -y 0 + update + set x [winfo rooty .t] + set y [expr [winfo rooty .t] + 150] + list [winfo containing [expr $x + 50] $y] \ + [winfo containing [expr $x + 150] $y] \ + [winfo containing [expr $x + 250] $y] \ + [winfo containing [expr $x + 350] $y] \ + [winfo containing [expr $x + 450] $y] +} {.t .t.f .t.f.f .t {}} +test unixWm-50.9 {Tk_CoordsToWindow procedure, unmapped windows} { + catch {destroy .t} + catch {destroy .t2} + sleep 500 ;# Give window manager time to catch up. + toplevel .t -width 200 -height 200 -bg green + wm geometry .t +0+0 + tkwait visibility .t + toplevel .t2 -width 200 -height 200 -bg red + wm geometry .t2 +0+0 + tkwait visibility .t2 + set result [list [winfo containing 100 100]] + wm iconify .t2 + lappend result [winfo containing 100 100] +} {.t2 .t} +test unixWm-50.10 {Tk_CoordsToWindow procedure, unmapped windows} { + catch {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 + place .t.f -x 25 -y 25 + tkwait visibility .t.f + set result [list [winfo containing 100 100]] + place forget .t.f + update + lappend result [winfo containing 100 100] +} {.t.f .t} +eval destroy [winfo children .] +wm deiconify . + +# No tests for UpdateVRootGeometry, Tk_GetVRootGeometry, +# Tk_MoveToplevelWindow, UpdateWmProtocols, or TkWmProtocolEventProc. + +test unixWm-51.1 {TkWmRestackToplevel procedure, basic tests} {nonPortable} { + makeToplevels + update + raise .raise1 + winfo containing [winfo rootx .raise1] [winfo rooty .raise1] +} .raise1 +test unixWm-51.2 {TkWmRestackToplevel procedure, basic tests} {nonPortable} { + makeToplevels + update + raise .raise2 + winfo containing [winfo rootx .raise1] [winfo rooty .raise1] +} .raise2 +test unixWm-51.3 {TkWmRestackToplevel procedure, basic tests} {nonPortable} { + makeToplevels + update + raise .raise3 + raise .raise2 + raise .raise1 .raise3 + set result [winfo containing [winfo rootx .raise1] \ + [winfo rooty .raise1]] + destroy .raise2 + sleep 500 + list $result [winfo containing [winfo rootx .raise1] \ + [winfo rooty .raise1]] +} {.raise2 .raise1} +test unixWm-51.4 {TkWmRestackToplevel procedure, basic tests} {nonPortable} { + makeToplevels + raise .raise2 + raise .raise1 + lower .raise3 .raise1 + set result [winfo containing 100 100] + destroy .raise1 + sleep 500 + lappend result [winfo containing 100 100] +} {.raise1 .raise3} +test unixWm-51.5 {TkWmRestackToplevel procedure, basic tests} {nonPortable} { + makeToplevels + update + raise .raise2 + raise .raise1 + raise .raise3 + frame .raise1.f1 + frame .raise1.f1.f2 + lower .raise3 .raise1.f1.f2 + set result [winfo containing [winfo rootx .raise1] \ + [winfo rooty .raise1]] + destroy .raise1 + sleep 500 + list $result [winfo containing [winfo rootx .raise2] \ + [winfo rooty .raise2]] +} {.raise1 .raise3} +foreach w [winfo children .] { + catch {destroy $w} +} +test unixWm-51.6 {TkWmRestackToplevel procedure, window to be stacked isn't mapped} { + catch {destroy .t} + toplevel .t -width 200 -height 200 -bg green + wm geometry .t +0+0 + tkwait visibility .t + catch {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} { + foreach w {.t .t2 .t3} { + catch {destroy $w} + toplevel $w -width 200 -height 200 -bg green + wm geometry $w +0+0 + } + raise .t .t2 + update + set result [list [winfo containing 100 100]] + lower .t3 + lappend result [winfo containing 100 100] +} {.t3 .t} +test unixWm-51.8 {TkWmRestackToplevel procedure, overrideredirect windows} { + catch {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} + toplevel .t2 -width 200 -height 200 -bg red + wm overrideredirect .t2 1 + wm geometry .t2 +0+0 + tkwait visibility .t2 + + # Need to use vrootx and vrooty to make tests work correctly with + # virtual root window measures managers: overrideredirect windows + # come up at (0,0) in display coordinates, not virtual root + # coordinates. + + set x [expr 100-[winfo vrootx .]] + set y [expr 100-[winfo vrooty .]] + set result [list [winfo containing $x $y]] + raise .t + lappend result [winfo containing $x $y] + raise .t2 + lappend result [winfo containing $x $y] +} {.t2 .t .t2} +test unixWm-51.9 {TkWmRestackToplevel procedure, other window overrideredirect} { + foreach w {.t .t2 .t3} { + catch {destroy $w} + toplevel $w -width 200 -height 200 -bg green + wm overrideredirect $w 1 + wm geometry $w +0+0 + tkwait visibility $w + } + lower .t3 .t2 + update + + # Need to use vrootx and vrooty to make tests work correctly with + # virtual root window measures managers: overrideredirect windows + # come up at (0,0) in display coordinates, not virtual root + # coordinates. + + set x [expr 100-[winfo vrootx .]] + set y [expr 100-[winfo vrooty .]] + set result [list [winfo containing $x $y]] + lower .t2 + lappend result [winfo containing $x $y] +} {.t2 .t3} +test unixWm-51.10 {TkWmRestackToplevel procedure, don't move window that's already in the right place} { + makeToplevels + raise .raise1 + set time [lindex [time {raise .raise1}] 0] + expr {$time < 2000000} +} 1 +test unixWm-51.11 {TkWmRestackToplevel procedure, don't move window that's already in the right place} { + makeToplevels + set time [lindex [time {lower .raise1}] 0] + expr {$time < 2000000} +} 1 +test unixWm-51.12 {TkWmRestackToplevel procedure, don't move window that's already in the right place} { + makeToplevels + set time [lindex [time {raise .raise3 .raise2}] 0] + expr {$time < 2000000} +} 1 +test unixWm-51.13 {TkWmRestackToplevel procedure, don't move window that's already in the right place} { + makeToplevels + set time [lindex [time {lower .raise1 .raise2}] 0] + expr {$time < 2000000} +} 1 + +test unixWm-52.1 {TkWmAddToColormapWindows procedure} { + catch {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} { + catch {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 + pack .t.f + update + wm colormap .t +} {.t.f .t} +test unixWm-52.3 {TkWmAddToColormapWindows procedure} { + catch {destroy .t} + toplevel .t -colormap new + wm geom .t +0+0 + frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f + frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f2 + update + wm colormap .t +} {.t.f .t.f2 .t} +test unixWm-52.4 {TkWmAddToColormapWindows procedure} { + catch {destroy .t} + toplevel .t -colormap new + wm geom .t +0+0 + frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f + update + wm colormapwindows .t .t.f + frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f2 + update + wm colormapwindows .t +} {.t.f} + +test unixWm-53.1 {TkWmRemoveFromColormapWindows procedure} { + catch {destroy .t} + toplevel .t -colormap new + wm geom .t +0+0 + frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f + frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f2 + update + destroy .t.f2 + wm colormap .t +} {.t.f .t} +test unixWm-53.2 {TkWmRemoveFromColormapWindows procedure} { + catch {destroy .t} + toplevel .t -colormap new + wm geom .t +0+0 + frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f + frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f2 + update + wm colormapwindows .t .t.f2 + destroy .t.f2 + wm colormap .t +} {} + +test unixWm-54.1 {TkpMakeMenuWindow procedure, setting save_under} { + catch {destroy .t} + catch {destroy .m} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + bind .t <Expose> {set x exposed} + wm geom .t +0+0 + update + menu .m + .m add command -label First + .m add command -label Second + .m add command -label Third + .m post 30 30 + update + set x {no event} + destroy .m + set x +} {no event} +test unixWm-54.2 {TkpMakeMenuWindow procedure, setting override_redirect} { + catch {destroy .m} + menu .m + .m add command -label First + .m add command -label Second + .m add command -label Third + .m post 30 30 + update + set result [wm overrideredirect .m] + destroy .m + set result +} {1} + +# No tests for TkGetPointerCoords, CreateWrapper, or GetMaxSize. + +test unixWm-55.1 {TkUnixSetMenubar procedure} {unixOnly} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + wm geom .t +0+0 + update + frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green + testmenubar window .t .t.f + update + list [winfo ismapped .t.f] [winfo geometry .t.f] \ + [expr [winfo rootx .t] - [winfo rootx .t.f]] \ + [expr [winfo rooty .t] - [winfo rooty .t.f]] +} {1 300x30+0+0 0 30} +test unixWm-55.2 {TkUnixSetMenubar procedure, removing menubar} {unixOnly} { + catch {destroy .t} + catch {destroy .f} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + wm geom .t +0+0 + update + set x [winfo rootx .t] + set y [winfo rooty .t] + frame .f -width 400 -height 30 -bd 2 -relief raised -bg green + testmenubar window .t .f + update + testmenubar window .t {} + update + list [winfo ismapped .f] [winfo geometry .f] \ + [expr [winfo rootx .t] - $x] \ + [expr [winfo rooty .t] - $y] \ + [expr [winfo rootx .] - [winfo rootx .f]] \ + [expr [winfo rooty .] - [winfo rooty .f]] +} {0 300x30+0+0 0 0 0 0} +test unixWm-55.3 {TkUnixSetMenubar procedure, removing geometry manager} {unixOnly} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + wm geom .t +0+0 + update + set x [winfo rootx .t] + set y [winfo rooty .t] + frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green + testmenubar window .t .t.f + update + testmenubar window .t {} + update + set result "[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]" + .t.f configure -height 100 + update + 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} {unixOnly} { + catch {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 + wm geom .t +0+0 + update + list [winfo ismapped .t.f] [winfo geometry .t.f] \ + [expr [winfo rootx .t] - [winfo rootx .t.f]] \ + [expr [winfo rooty .t] - [winfo rooty .t.f]] +} {1 300x30+0+0 0 30} +test unixWm-55.5 {TkUnixSetMenubar procedure, changing menubar} {unixOnly} { + catch {destroy .t} + catch {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 + update + set y [winfo rooty .t] + frame .f -width 400 -height 50 -bd 2 -relief raised -bg green + testmenubar window .t .t.f + update + set result {} + lappend result [winfo ismapped .f] [winfo ismapped .t.f] + lappend result [expr [winfo rooty .t.f] - $y] + testmenubar window .t .f + update + lappend result [winfo ismapped .f] [winfo ismapped .t.f] + lappend result [expr [winfo rooty .f] - $y] +} {0 1 0 1 0 0} +test unixWm-55.6 {TkUnixSetMenubar procedure, changing menubar to self} {unixOnly} { + catch {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 + wm geom .t +0+0 + update + testmenubar window .t .t.f + update + list [winfo ismapped .t.f] [winfo geometry .t.f] \ + [expr [winfo rootx .t] - [winfo rootx .t.f]] \ + [expr [winfo rooty .t] - [winfo rooty .t.f]] +} {1 300x30+0+0 0 30} +test unixWm-55.7 {TkUnixSetMenubar procedure, unsetting event handler} {unixOnly} { + catch {destroy .t} + catch {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 + wm geom .t +0+0 + update + set y [winfo rooty .t] + testmenubar window .t .t.f + update + set result [expr [winfo rooty .t] - $y] + testmenubar window .t .f + update + lappend result [expr [winfo rooty .t] - $y] + destroy .t.f + update + lappend result [expr [winfo rooty .t] - $y] +} {30 40 40} + +test unixWm-56.1 {MenubarDestroyProc procedure} {unixOnly} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + wm geom .t +0+0 + update + set y [winfo rooty .t] + frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green + testmenubar window .t .t.f + update + set result [expr [winfo rooty .t] - $y] + destroy .t.f + update + lappend result [expr [winfo rooty .t] - $y] +} {30 0} + +test unixWm-57.1 {MenubarReqProc procedure} {unixOnly} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + wm geom .t +0+0 + update + set x [winfo rootx .t] + set y [winfo rooty .t] + frame .t.f -width 400 -height 10 -bd 2 -relief raised -bg green + testmenubar window .t .t.f + update + set result "[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]" + .t.f configure -height 100 + update + lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y] +} {0 10 0 100} +test unixWm-57.2 {MenubarReqProc procedure} {unixOnly} { + catch {destroy .t} + toplevel .t -width 300 -height 200 -bd 2 -relief raised + wm geom .t +0+0 + update + set x [winfo rootx .t] + set y [winfo rooty .t] + frame .t.f -width 400 -height 20 -bd 2 -relief raised -bg green + testmenubar window .t .t.f + update + set result "[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]" + .t.f configure -height 0 + update + lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y] +} {0 20 0 1} + +# Test exit processing and cleanup: + +test unixWm-58.1 {exit processing} { + catch {removeFile script} + set fd [open script w] + puts $fd { + update + exit + } + close $fd + if {[catch {exec $tktest script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } + list $error $msg +} {0 {}} +test unixWm-58.2 {exit processing} { + catch {removeFile script} + set fd [open script w] + puts $fd { + interp create x + x eval {set argc 2} + x eval {set argv "-geometry 10x10+0+0"} + x eval {load {} Tk} + update + exit + } + close $fd + if {[catch {exec $tktest script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } + list $error $msg +} {0 {}} +test unixWm-58.3 {exit processing} { + catch {removeFile script} + set fd [open script w] + puts $fd { + interp create x + x eval {set argc 2} + x eval {set argv "-geometry 10x10+0+0"} + x eval {load {} Tk} + x eval { + button .b -text hello + bind .b <Destroy> foo + } + x alias foo destroy_x + proc destroy_x {} {interp delete x} + update + exit + } + close $fd + if {[catch {exec $tktest script -geometry 10x10+0+0} msg]} { + set error 1 + } else { + set error 0 + } + list $error $msg +} {0 {}} + + +catch {destroy .t} +concat {} diff --git a/tests/util.test b/tests/util.test new file mode 100644 index 0000000..3b41e49 --- /dev/null +++ b/tests/util.test @@ -0,0 +1,70 @@ +# This file is a Tcl script to test out the procedures in the file +# tkUtil.c. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) util.test 1.4 96/02/16 10:55:50 + +if {[string compare test [info procs test]] == 1} then \ + {source defs} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +listbox .l -width 20 -height 5 -relief sunken -bd 2 +pack .l +.l insert 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 +update +test util-1.1 {Tk_GetScrollInfo procedure} { + list [catch {.l yview moveto a b} msg] $msg +} {1 {wrong # args: should be ".l yview moveto fraction"}} +test util-1.2 {Tk_GetScrollInfo procedure} { + list [catch {.l yview moveto xyz} msg] $msg +} {1 {expected floating-point number but got "xyz"}} +test util-1.3 {Tk_GetScrollInfo procedure} { + .l yview 0 + .l yview moveto .5 + .l yview +} {0.5 0.75} +test util-1.4 {Tk_GetScrollInfo procedure} { + list [catch {.l yview scroll a} msg] $msg +} {1 {wrong # args: should be ".l yview scroll number units|pages"}} +test util-1.5 {Tk_GetScrollInfo procedure} { + list [catch {.l yview scroll a b c} msg] $msg +} {1 {wrong # args: should be ".l yview scroll number units|pages"}} +test util-1.6 {Tk_GetScrollInfo procedure} { + list [catch {.l yview scroll xyz units} msg] $msg +} {1 {expected integer but got "xyz"}} +test util-1.7 {Tk_GetScrollInfo procedure} { + .l yview 0 + .l yview scroll 2 pages + .l nearest 0 +} {6} +test util-1.8 {Tk_GetScrollInfo procedure} { + .l yview 15 + .l yview scroll -2 pages + .l nearest 0 +} {9} +test util-1.9 {Tk_GetScrollInfo procedure} { + .l yview 0 + .l yview scroll 2 units + .l nearest 0 +} {2} +test util-1.10 {Tk_GetScrollInfo procedure} { + .l yview 15 + .l yview scroll -2 units + .l nearest 0 +} {13} +test util-1.11 {Tk_GetScrollInfo procedure} { + list [catch {.l yview scroll 3 zips} msg] $msg +} {1 {bad argument "zips": must be units or pages}} +test util-1.12 {Tk_GetScrollInfo procedure} { + list [catch {.l yview dropdead 3 times} msg] $msg +} {1 {unknown option "dropdead": must be moveto or scroll}} diff --git a/tests/visual b/tests/visual new file mode 100644 index 0000000..90e8558 --- /dev/null +++ b/tests/visual @@ -0,0 +1,81 @@ +#!/usr/local/bin/wish -f +# +# This script displays provides visual tests for many of Tk's features. +# Each test displays a window with various information in it, along +# with instructions about how the window should appear. You can look +# at the window to make sure it appears as expected. Individual tests +# are kept in separate ".tcl" files in this directory. +# +# SCCS: @(#) visual 1.5 97/06/13 16:37:29 + +set auto_path ". $auto_path" +wm title . "Visual Tests for Tk" + +#------------------------------------------------------- +# The code below create the main window, consisting of a +# menu bar and a message explaining the basic operation +# of the program. +#------------------------------------------------------- + +frame .menu -relief raised -borderwidth 1 +message .msg -font {Times 18} -relief raised -width 4i \ + -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets." + +pack .menu -side top -fill x +pack .msg -side bottom -expand yes -fill both + +#------------------------------------------------------- +# The code below creates all the menus, which invoke procedures +# to create particular demonstrations of various widgets. +#------------------------------------------------------- + +menubutton .menu.file -text "File" -menu .menu.file.m +menu .menu.file.m +.menu.file.m add command -label "Quit" -command exit + +menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m +menu .menu.group1.m +.menu.group1.m add command -label "Canvas arcs" -command {source arc.tcl} +.menu.group1.m add command -label "Beveled borders in text widgets" \ + -command {source bevel.tcl} +.menu.group1.m add command -label "Colormap management" \ + -command {source cmap.tcl} +.menu.group1.m add command -label "Label/button geometry" \ + -command {source butGeom.tcl} +.menu.group1.m add command -label "Label/button colors" \ + -command {source butGeom2.tcl} + +menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m +menu .menu.ps.m +.menu.ps.m add command -label "Rectangles and other graphics" \ + -command {source canvPsGrph.tcl} +.menu.ps.m add command -label "Text" \ + -command {source canvPsText.tcl} +.menu.ps.m add command -label "Bitmaps" \ + -command {source canvPsBmap.tcl} +.menu.ps.m add command -label "Arcs" \ + -command {source canvPsArc.tcl} + +pack .menu.file .menu.group1 .menu.ps -side left -padx 1m + +# Set up for keyboard-based menu traversal + +bind . <Any-FocusIn> { + if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { + focus .menu + } +} +tk_menuBar .menu .menu.file .menu.group1 .menu.ps + +# The following procedure is invoked to print the contents of a canvas: + +proc lpr c { + exec rm -f tmp.ps + $c postscript -file tmp.ps + exec lpr tmp.ps +} + +# Set up a class binding to allow objects to be deleted from a canvas +# by clicking with mouse button 1: + +bind Canvas <1> {%W delete [%W find closest %x %y]} diff --git a/tests/visual.test b/tests/visual.test new file mode 100644 index 0000000..853554e --- /dev/null +++ b/tests/visual.test @@ -0,0 +1,312 @@ +# This file is a Tcl script to test the visual- and colormap-handling +# procedures in the file tkVisual.c. It is organized in the standard +# fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) visual.test 1.11 96/02/16 10:55:34 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . +update + +# eatColors -- +# Creates a toplevel window and allocates enough colors in it to +# use up all the slots in the colormap. +# +# Arguments: +# w - Name of toplevel window to create. + +proc eatColors {w} { + catch {destroy $w} + toplevel $w + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] + $w.c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } + } + update +} + +# colorsFree -- +# +# Returns 1 if there appear to be free colormap entries in a window, +# 0 otherwise. +# +# Arguments: +# w - Name of window in which to check. +# red, green, blue - Intensities to use in a trial color allocation +# to see if there are colormap entries free. + +proc colorsFree {w {red 31} {green 245} {blue 192}} { + set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] + expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ + && ([lindex $vals 2]/256 == $blue) +} + +# If more than one visual type is available for the screen, pick one +# that is *not* the default. + +set default "[winfo visual .] [winfo depth .]" +set avail [winfo visualsavailable .] +set other {} +if {[llength $avail] > 1} { + foreach visual $avail { + if {$visual != $default} { + set other $visual + break + } + } +} + +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.5 {Tk_GetVisual, default colormap} { + catch {destroy .t1} + toplevel .t1 -width 250 -height 100 -visual default + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} $default + +set i 1 +foreach visual $avail { + test visual-2.$i {Tk_GetVisual, different visual types} {nonPortable} { + catch {destroy .t1} + toplevel .t1 -width 250 -height 100 -visual $visual + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" + } $visual + incr i +} + +test visual-3.1 {Tk_GetVisual, parsing visual string} { + catch {destroy .t1} + toplevel .t1 -width 250 -height 100 \ + -visual "[winfo visual .][winfo depth .]" + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} $default +test visual-3.2 {Tk_GetVisual, parsing visual string} { + catch {destroy .t1} + list [catch { + toplevel .t1 -width 250 -height 100 -visual goop20 + wm geometry .t1 +0+0 + } msg] $msg +} {1 {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} +test visual-3.3 {Tk_GetVisual, parsing visual string} { + catch {destroy .t1} + list [catch { + toplevel .t1 -width 250 -height 100 -visual d + wm geometry .t1 +0+0 + } msg] $msg +} {1 {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} +test visual-3.4 {Tk_GetVisual, parsing visual string} { + catch {destroy .t1} + list [catch { + toplevel .t1 -width 250 -height 100 -visual static + wm geometry .t1 +0+0 + } msg] $msg +} {1 {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} +test visual-3.5 {Tk_GetVisual, parsing visual string} { + catch {destroy .t1} + list [catch { + toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x" + wm geometry .t1 +0+0 + } msg] $msg +} {1 {expected integer but got "48x"}} + +if {$other != ""} { + catch {destroy .t1} + catch {destroy .t2} + catch {destroy .t3} + toplevel .t1 -width 250 -height 100 -visual $other + wm geom .t1 +0+0 + toplevel .t2 -width 200 -height 80 -visual [winfo visual .] + 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]] + 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"}} +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" + 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)} { + 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}} + } + catch {destroy .t1} + catch {destroy .t2} +} + +test visual-8.1 {Tk_FreeColormap procedure} { + foreach w [winfo child .] { + destroy $w + } + toplevel .t1 -width 300 -height 180 -colormap new + wm geometry .t1 +0+0 + foreach i {.t2 .t3 .t4} { + toplevel $i -width 250 -height 150 -colormap .t1 + wm geometry $i +0+0 + } + destroy .t1 + destroy .t3 + destroy .t4 + update +} {} +if {$other != {}} { + test visual-8.2 {Tk_FreeColormap procedure} { + foreach w [winfo child .] { + destroy $w + } + 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 + } {} +} + +foreach w [winfo child .] { + destroy $w +} +rename eatColors {} +rename colorsFree {} diff --git a/tests/winButton.test b/tests/winButton.test new file mode 100644 index 0000000..7125aa5 --- /dev/null +++ b/tests/winButton.test @@ -0,0 +1,154 @@ +# This file is a Tcl script to test the Windows specific behavior of +# labels, buttons, checkbuttons, and radiobuttons in Tk (i.e., all the +# widgets defined in tkWinButton.c). It is organized in the standard +# fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winButton.test 1.3 97/07/01 18:11:44 + +if {$tcl_platform(platform)!="windows"} { + return +} + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\"" + puts "image, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +proc bogusTrace args { + error "trace aborted" +} +catch {unset value} +catch {unset value2} + +eval image delete [image names] +image create test image1 +label .l -text Label +button .b -text Button +checkbutton .c -text Checkbutton +radiobutton .r -text Radiobutton +pack .l .b .c .r +update + +test winbutton-1.1 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + 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 + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {68 48 71 51 96 50 96 50} +test winbutton-1.2 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + 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 + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {23 33 26 36 51 35 51 35} +test winbutton-1.3 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + label .b1 -bitmap question -bd 3 -highlightthickness 4 + button .b2 -bitmap question -bd 3 -highlightthickness 0 + checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \ + -indicatoron 0 + radiobutton .b4 -bitmap question -bd 3 -indicatoron false + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {31 41 24 34 26 36 26 36} +test winbutton-1.4 {TkpComputeButtonGeometry procedure} {nonPortable} { + eval destroy [winfo children .] + 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} + checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -font {{MS Sans Serif} 8} + radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -font {{MS Sans Serif} 8} + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {45 21 54 30 74 27 76 25} +test winbutton-1.5 {TkpComputeButtonGeometry procedure} {nonPortable} { + eval destroy [winfo children .] + 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] +} {142 69} +test winbutton-1.6 {TkpComputeButtonGeometry procedure} {nonPortable} { + eval destroy [winfo children .] + 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] +} {180 43} +test winbutton-1.7 {TkpComputeButtonGeometry procedure} {nonPortable} { + eval destroy [winfo children .] + label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 + button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 + checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2 + radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -width 4 + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {64 21 54 82 153 40 59 25} +test winbutton-1.8 {TkpComputeButtonGeometry procedure} {nonPortable} { + eval destroy [winfo children .] + label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ + -highlightthickness 4 + button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \ + -highlightthickness 0 + checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 \ + -highlightthickness 1 -indicatoron no + radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0 + pack .b1 .b2 .b3 .b4 + update + list [winfo reqwidth .b1] [winfo reqheight .b1] \ + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} {53 29 52 28 56 28 58 26} +test winbutton-1.9 {TkpComputeButtonGeometry procedure} { + eval destroy [winfo children .] + button .b2 -bitmap question -default normal + list [winfo reqwidth .b2] [winfo reqheight .b2] +} {24 34} + +eval destroy [winfo children .] diff --git a/tests/winClipboard.test b/tests/winClipboard.test new file mode 100644 index 0000000..222c23f --- /dev/null +++ b/tests/winClipboard.test @@ -0,0 +1,44 @@ +# This file is a Tcl script to test out Tk's Windows specific +# clipboard code. It is organized in the standard fashion for Tcl +# tests. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winClipboard.test 1.3 97/07/01 18:10:37 + +if {$tcl_platform(platform)!="windows"} { + return +} + +if {[string compare test [info procs test]] == 1} { + source defs +} + +test winClipboard-1.1 {TkSelGetSelection} { + 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} { + clipboard clear + clipboard append {} + list [selection get -selection CLIPBOARD] [testclipboard] +} {{} {}} +test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} { + clipboard clear + clipboard append abcd + list [selection get -selection CLIPBOARD] [testclipboard] +} {abcd abcd} +test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} { + clipboard clear + clipboard append "line 1\nline 2" + list [selection get -selection CLIPBOARD] [testclipboard] +} [list "line 1\nline 2" "line 1\r\nline 2"] + diff --git a/tests/winFont.test b/tests/winFont.test new file mode 100644 index 0000000..a047108 --- /dev/null +++ b/tests/winFont.test @@ -0,0 +1,177 @@ +# This file is a Tcl script to test out the procedures in tkWinFont.c. +# It is organized in the standard fashion for Tcl tests. +# +# Many 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-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winFont.test 1.7 97/04/25 16:55:00 + +if {$tcl_platform(platform)!="windows"} { + return +} + +if {[string compare test [info procs test]] != 0} { + source defs +} + +catch {destroy .b} +catch {font delete xyz} + +toplevel .b +update idletasks + +set courier {Courier 14} +set cx [font measure $courier 0] + +label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed +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]" +} + +test winfont-1.1 {TkpGetNativeFont procedure: not native} { + list [catch {font measure {} xyz} msg] $msg +} {1 {font "" doesn't exist}} +test winfont-1.2 {TkpGetNativeFont procedure: native} { + font measure ansifixed 0 + font measure ansi 0 + font measure device 0 + font measure oemfixed 0 + font measure systemfixed 0 + font measure system 0 + set x {} +} {} + +test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} { + expr [font actual {-size -10} -size]>0 +} {1} +test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} { + expr [font actual {-family Arial} -size]>0 +} {1} +test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} { + font actual {-weight normal} -weight +} {normal} +test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} { + font actual {-weight bold} -weight +} {bold} +test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} { + catch {expr {[font actual {-size 10} -size]}} +} 0 +test winfont-2.6 {TkpGetFontFromAttributes procedure: family} { + font actual {-family Arial} -family +} {Arial} +test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} { + 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} { + 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} { + 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} { + # No way to get it to fail! Any font name is acceptable. +} {} + +test winfont-3.1 {TkpDeleteFont procedure} { + font actual {-family xyz} + set x {} +} {} + +test winfont-4.1 {TkpGetFontFamilies procedure} { + font families + set x {} +} {} + +test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} { + .b.l config -wrap 0 -text "000000" + getsize +} "[expr $ax*6] $ay" +test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} { + .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" + getsize +} "[expr $ax*256] $ay" +test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} { + .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} { + .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} { + .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} { + .b.l config -text "000000" -wrap 1 + getsize +} "$ax [expr $ay*6]" +test winfont-5.7 {Tk_MeasureChars procedure: whole words} { + .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} { + .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} { + .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} { + .b.l config -wrap [expr $ax*12] -text "0000000000000000" + getsize +} "[expr $ax*12] [expr $ay*2]" + +test winfont-6.1 {Tk_DrawChars procedure: loop test} { + .b.l config -text "a" + update +} {} + +test winfont-7.1 {AllocFont procedure: use old font} { + font create xyz + catch {destroy .c} + button .c -font xyz + font configure xyz -family times + update + destroy .c + font delete xyz +} {} +test winfont-7.2 {AllocFont procedure: extract info from logfont} { + 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} { + font metric {arial 10 bold italic underline overstrike} -fixed +} {0} +test winfont-7.4 {AllocFont procedure: extract info from textmetric} { + font metric systemfixed -fixed +} {1} + +destroy .b diff --git a/tests/winMenu.test b/tests/winMenu.test new file mode 100644 index 0000000..ceeced6 --- /dev/null +++ b/tests/winMenu.test @@ -0,0 +1,1030 @@ +# 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-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winMenu.test 1.19 97/07/02 11:29:57 + +if {$tcl_platform(platform) != "windows"} { + return +} + +if {![info exists INTERACTIVE]} { + puts " Some tests were skipped because they could not be performed" + puts " automatically on this platform. If you wish to execute them" + puts " interactively, set the TCL variable INTERACTIVE and re-run" + puts " the test." + set testConfig(menuInteractive) 0 +} else { + set testConfig(menuInteractive) 1 +} + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +proc deleteWindows {} { + foreach i [winfo children .] { + catch [destroy $i] + } +} + +deleteWindows +wm geometry . {} +raise . + +test winMenu-1.1 {GetNewID} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {destroy .m1} msg] $msg +} {0 {}} + +test winMenu-3.1 {TkpNewMenu} { + catch {destroy .m1} + list [catch {menu .m1} msg] $msg [catch {destroy .m1} msg2] $msg2 +} {0 .m1 0 {}} +test winMenu-3.2 {TkpNewMenu} { + 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-4.1 {TkpDestroyMenu} { + catch {destroy .m1} + menu .m1 + list [catch {destroy .m1} msg] $msg +} {0 {}} +test winMenu-4.2 {TkpDestroyMenu - help menu} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -menu .m1.system + . configure -menu .m1 + list [catch {destroy .m1.system} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} + +test winMenu-5.1 {TkpDestroyMenuEntry} { + catch {destroy .m1} + . configure -menu "" + menu .m1 + .m1 add command -label "test" + update idletasks + list [catch {.m1 delete 1} msg] $msg [destroy .m1] +} {0 {} {}} + +test winMenu-6.1 {GetEntryText} { + catch {destroy .m1} + list [catch {menu .m1} msg] $msg [destroy .m1] +} {0 .m1 {}} +test winMenu-6.2 {GetEntryText} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -bitmap questhead} msg] $msg [destroy .m1] +} {0 {} {}} +test winMenu-6.4 {GetEntryText} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command} msg] $msg [destroy .m1] +} {0 {} {}} +test winMenu-6.5 {GetEntryText} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -label "foo"} msg] $msg [destroy .m1] +} {0 {} {}} +test winMenu-6.6 {GetEntryText} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -label "foo" -accel "bar"} msg] $msg [destroy .m1] +} {0 {} {}} +test winMenu-6.10 {GetEntryText} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command -label "foo" -accel "&bar"} msg] $msg [destroy .m1] +} {0 {} {}} +test winMenu-6.14 {GetEntryText} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -menu .m1.system + menu .m1.system + .m1.system add command -label foo + update idletasks + .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} { + catch {destroy .m1} + menu .m1 + .m1 add command -label Hello + update idletasks + .m1 add command -label foo + list [catch {update idletasks} msg] $msg [destroy .m1] +} {0 {} {}} +test winMenu-7.3 {ReconfigureWindowsMenu - zero items} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 -tearoff 0 + menu .m2 + .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} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -menu .m1.file + menu .m1.file -tearoff 0 + . configure -menu .m1 + list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -menu .m1.system + menu .m1.system -tearoff 0 + . configure -menu .m1 + update idletasks + .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} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -menu .m1.system + menu .m1.system -tearoff 0 + . configure -menu .m1 + list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add cascade -menu .m1.system + menu .m1.system -tearoff 0 + .m1.system add command -label Hello + update idletasks + . configure -menu .m1 + list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} +test winMenu-7.19 {ReconfigureWindowsMenu - column break} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add command -label one + .m1 add command -label two -columnbreak 1 + list [catch {update idletasks} msg] $msg [destroy .m1] +} {0 {} {}} + +#Don't know how to generate nested post menus +test winMenu-8.1 {TkpPostMenu} { + 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} { + catch {destroy .m1} + menu .m1 -postcommand "destroy .m1" + list [.m1 post 40 40] [winfo exists .m1] +} {{} 0} +test winMenu-8.3 {TkpPostMenu - popup menu} {menuInteractive} { + 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} {menuInteractive} { + catch {destroy .mb} + menubutton .mb -text test -menu .mb.menu + menu .mb.menu + .mb.menu add command -label "winMenu-8.4 - Hit ESCAPE." + pack .mb + list [tkMbPost .mb] [destroy .m1] +} {{} {}} +test winMenu-8.5 {TkpPostMenu - update not pending} {menuInteractive} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "winMenu-8.5 - Hit ESCAPE." + update idletasks + list [catch {.m1 post 40 40} msg] $msg [destroy .m1] +} {0 {} {}} + +test winMenu-9.1 {TkpMenuNewEntry} { + catch {destroy .m1} + menu .m1 + list [catch {.m1 add command} msg] $msg [destroy .m1] +} {0 {} {}} + +test winMenu-10.1 {TkwinMenuProc} {menuInteractive} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "winMenu-10.1: Hit ESCAPE." + list [.m1 post 40 40] [destroy .m1] +} {{} {}} + +# Can't generate a WM_INITMENU without a Tk menu yet. +test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} {menuInteractive} { + 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} {menuInteractive} { + 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 {} {}} +# Can't test WM_MENUCHAR +test winMenu-11.3 {TkWinHandleMenuEvent - WM_MEASUREITEM} {menuInteractive} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "winMenu-11.3: Hit ESCAPE." + list [.m1 post 40 40] [destroy .m1] +} {{} {}} +test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {menuInteractive} { + 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.5 {TkWinHandleMenuEvent - WM_DRAWITEM} {menuInteractive} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "winMenu-11.5: Hit ESCAPE." + list [.m1 post 40 40] [destroy .m1] +} {{} {}} +test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} {menuInteractive} { + 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.7 {TkWinHandleMenuEvent - WM_INITMENU - not pending} {menuInteractive} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add command -label "winMenu-11.7: Hit ESCAPE" + update idletasks + list [catch {.m1 post 40 40} msg] $msg [destroy .m1] +} {0 {} {}} + +test winMenu-12.1 {TkpSetWindowMenuBar} { + 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} { + catch {destroy .m1} + . configure -menu "" + menu .m1 + .m1 add command -label foo + . configure -menu .m1 + list [catch {. configure -menu ""} msg] $msg [catch {destroy .m1} msg2] $msg2 +} {0 {} 0 {}} +test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} { + catch {destroy .m1} + . configure -menu "" + menu .m1 -tearoff 0 + .m1 add command -label foo + update idletasks + list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] +} {0 {} {} {}} + +test winMenu-13.1 {TkpSetMainMenubar - nothing to do} {} {} + +test winMenu-14.1 {GetMenuIndicatorGeometry} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test winMenu-14.2 {GetMenuIndicatorGeometry} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo -hidemargin 1 + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +test winMenu-15.1 {GetMenuAccelGeometry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo -accel Ctrl+U + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test winMenu-15.2 {GetMenuAccelGeometry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} +test winMenu-15.3 {GetMenuAccelGeometry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Ctrl+U" + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +test winMenu-16.1 {GetTearoffEntryGeometry} {menuInteractive} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add separator + list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] +} {0 {}} + +# Currently, the only callers to DrawWindowsSystemBitmap want things +# centered vertically, and either centered or right aligned horizontally. +test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} + +test winMenu-19.1 {DrawMenuEntryIndicator - not checkbutton or radiobutton} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-19.2 {DrawMenuEntryIndicator - not selected} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} { + catch {destroy .m1} + menu .m1 + .m1 add radiobutton -label foo + .m1 invoke foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-19.5 {DrawMenuEntryIndicator - disabled} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke foo + .m1 entryconfigure foo -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo -indicatoron 0 + .m1 invoke foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} + +test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} { + catch {destroy .m1} + menu .m1 -disabledforeground red + .m1 add command -label foo -accel "Ctrl+U" -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -accel "Ctrl+U" + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} { + catch {destroy .m1} + menu .m1 -disabledforeground "" + .m1 add command -label foo -accel "Ctrl+U" -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} {menuInteractive} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add separator + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} + +test winMenu-22.1 {DrawMenuUnderline} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -underline 0 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} + +test winMenu-23.1 {Don't know how to test MenuKeyBindProc} {} {} +test winMenu-24.1 {TkpInitializeMenuBindings called at boot time} {} {} + +test winMenu-25.1 {DrawMenuEntryLabel - normal} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} { + catch {destroy .m1} + menu .m1 -disabledforeground red + .m1 add command -label foo -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} { + catch {destroy .m1} + menu .m1 -disabledforeground "" + .m1 add command -label foo -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} + +test winMenu-26.1 {TkpComputeMenubarGeometry} { + catch {destroy .m1} + menu .m1 + .m1 add cascade -label File + list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] +} {{} {} {}} + +test winMenu-27.1 {DrawTearoffEntry} {menuInteractive} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add command -label One + update idletasks + list [catch {.m1 add command -label Two} msg] $msg [destroy .m1] +} {0 {} {}} + +test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -activeforeground red + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} { + catch {destroy .m1} + menu .m1 + set tk_strictMotif 1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] [set tk_strictMotif 0] +} {{} {} 0} +test winMenu-29.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} { + catch {destroy .m1} + menu .m1 -disabledforeground blue + .m1 add command -label foo -state disabled -background red + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} { + catch {destroy .m1} + menu .m1 -disabledforeground blue + .m1 add command -label foo -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} { + catch {destroy .m1} + menu .m1 -disabledforeground "" + .m1 add command -label foo -state disabled + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -foreground red + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo -selectcolor orange + .m1 invoke 1 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label foo + .m1 invoke 1 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -activebackground green + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.12 {TkpDrawMenuEntry - border} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} { + catch {destroy .m1} + set tk_strictMotif 1 + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] [set tk_strictMotif 0] +} {{} {} 0} +test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -activeforeground yellow + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.15 {TkpDrawMenuEntry - active border} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + .m1 entryconfigure 1 -state active + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo -font "Helvectica 72" + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.17 {TkpDrawMenuEntry - font} { + catch {destroy .m1} + menu .m1 -font "Courier 72" + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.18 {TkpDrawMenuEntry - separator} { + catch {destroy .m1} + menu .m1 + .m1 add separator + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.19 {TkpDrawMenuEntry - standard} { + catch {destroy .mb} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} { + 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 [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.21 {TkpDrawMenuEntry - indicator} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label winMenu-31.20 + .m1 invoke winMenu-31.20 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-29.22 {TkpDrawMenuEntry - indicator} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label winMenu-31.21 -hidemargin 1 + .m1 invoke winMenu-31.21 + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} + +test winMenu-30.1 {GetMenuLabelGeometry - image} { + 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 winMenu-30.2 {GetMenuLabelGeometry - bitmap} { + catch {destroy .m1} + menu .m1 + .m1 add command -bitmap questhead + list [update idletasks] [destroy .m1] +} {{} {}} +test winMenu-30.3 {GetMenuLabelGeometry - no text} { + catch {destroy .m1} + menu .m1 + .m1 add command + list [update idletasks] [destroy .m1] +} {{} {}} +test winMenu-30.4 {GetMenuLabelGeometry - text} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "This is a test." + list [update idletasks] [destroy .m1] +} {{} {}} + +test winMenu-31.1 {DrawMenuEntryBackground} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + list [update] [destroy .m1] +} {{} {}} +test winMenu-31.2 {DrawMenuEntryBackground} { + catch {destroy .m1} + menu .m1 + .m1 add command -label foo + set tearoff [tkTearOffMenu .m1 40 40] + $tearoff activate 0 + list [update] [destroy .m1] +} {{} {}} + +test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} { + catch {destroy .m1} + menu .m1 + list [update idletasks] [destroy .m1] +} {{} {}} +test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "one" + list [update idletasks] [destroy .m1] +} {{} {}} +test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add separator + list [update idletasks] [destroy .m1] +} {{} {}} +test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} { + catch {destroy .m1} + menubutton .mb -text "test" -menu .mb.m + menu .mb.m + .mb.m add command -label test + pack .mb + catch {tkMbPost .mb} + list [update] [destroy .mb] +} {{} {}} +test winMenu-32.6 {TkpComputeStandardMenuGeometry - standard label geometry} { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + list [update idletasks] [destroy .m1] +} {{} {}} +test winMenu-32.7 {TkpComputeStandardMenuGeometry - different font for entry} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + catch {destroy .m1} + menu .m1 + .m1 add checkbutton -label test + .m1 invoke 1 + list [update idletasks] [destroy .m1] +} {{} {}} +test winMenu-32.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } { + 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 winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unixOnly} { + 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 winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} { + catch {destroy .m1} + menu .m1 -tearoff 0 + list [update idletasks] [destroy .m1] +} {{} {}} +test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} { + 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 winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} { + 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 winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} { + 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 winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} { + 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} { + catch {destroy .t2} + catch {destroy .m1} + menu .m1 + menu .m1.system + .m1 add cascade -menu .m1.system + .m1.system add separator + .m1.system add command -label foo + toplevel .t2 -menu .m1 + wm geometry .t2 +0+0 + list [update idletasks] [destroy .m1] [destroy .t2] +} {{} {} {}} + +test winMenu-34.1 {TkpMenuInit called at boot time} {} {} + +deleteWindows diff --git a/tests/winWm.test b/tests/winWm.test new file mode 100644 index 0000000..c83e380 --- /dev/null +++ b/tests/winWm.test @@ -0,0 +1,219 @@ +# This file tests is a Tcl script to test the procedures in the file +# tkWinWm.c. It is organized in the standard fashion for Tcl tests. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winWm.test 1.5 97/08/13 15:42:46 + +if {$tcl_platform(platform) != "windows"} { + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + catch {destroy $i} +} + +# Measure the height of a single menu line + +toplevel .t +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 +update +set menuheight [winfo y .t] +.t.m add command -label "thisisreallylong" +wm geom .t -0-0 +update +set menuheight [expr $menuheight - [winfo y .t]] +destroy .t + +test winWm-1.1 {TkWmMapWindow} { + toplevel .t + wm override .t 1 + wm geometry .t +0+0 + update + set result [list [winfo rootx .t] [winfo rooty .t]] + destroy .t + set result +} {0 0} +test winWm-1.2 {TkWmMapWindow} { + toplevel .t + wm transient .t . + update + wm iconify . + update + wm deiconify . + update + catch {wm iconify .t} msg + destroy .t + set msg +} {can't iconify ".t": it is a transient} +test winWm-1.3 {TkWmMapWindow} { + toplevel .t + update + toplevel .t2 + update + set result [expr [winfo x .t] != [winfo x .t2]] + destroy .t .t2 + set result +} 1 +test winWm-1.4 {TkWmMapWindow} { + toplevel .t + wm geometry .t +10+10 + update + toplevel .t2 + wm geometry .t2 +40+10 + update + set result [list [winfo x .t] [winfo x .t2]] + destroy .t .t2 + set result +} {10 40} +test winWm-1.5 {TkWmMapWindow} { + toplevel .t + wm iconify .t + update + set result [wm state .t] + destroy .t + set result +} iconic + +test winWm-2.1 {TkpWmSetState} { + toplevel .t + wm geometry .t 150x50+10+10 + update + set result [wm state .t] + wm iconify .t + update + lappend result [wm state .t] + wm deiconify .t + update + lappend result [wm state .t] + destroy .t + set result +} {normal iconic normal} +test winWm-2.2 {TkpWmSetState} { + toplevel .t + wm geometry .t 150x50+10+10 + update + set result [wm state .t] + wm withdraw .t + update + lappend result [wm state .t] + wm iconify .t + update + lappend result [wm state .t] + wm deiconify .t + update + lappend result [wm state .t] + destroy .t + set result +} {normal withdrawn iconic normal} +test winWm-2.3 {TkpWmSetState} { + set result {} + toplevel .t + wm geometry .t 150x50+10+10 + update + lappend result [list [wm state .t] [wm geometry .t]] + wm iconify .t + update + lappend result [list [wm state .t] [wm geometry .t]] + wm geometry .t 200x50+10+10 + update + lappend result [list [wm state .t] [wm geometry .t]] + wm deiconify .t + update + lappend result [list [wm state .t] [wm geometry .t]] + destroy .t + 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} { + toplevel .t + wm geometry .t +0+0 + button .t.b + pack .t.b + update + set x [winfo x .t.b] + destroy .t + toplevel .t + wm geometry .t +0+0 + button .t.b + update + pack .t.b + update + set x [expr $x == [winfo x .t.b]] + destroy .t + set x +} 1 + +test winWm-4.1 {ConfigureTopLevel: menu resizing} { + set result {} + toplevel .t + frame .t.f -width 150 -height 50 -bg 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 + update + set result [expr $y - [winfo y .t]] + destroy .t + set result +} [expr $menuheight + 1] + +test winWm-5.1 {UpdateGeometryInfo: menu resizing} { + set result {} + toplevel .t + frame .t.f -width 150 -height 50 -bg red + pack .t.f + update + set result [winfo height .t] + menu .t.m + .t.m add command -label foo + .t conf -menu .t.m + update + lappend result [winfo height .t] + .t.m add command -label "thisisreallylong" + .t.m add command -label "thisisreallylong" + update + lappend result [winfo height .t] + destroy .t + set result +} {50 50 50} +test winWm-5.2 {UpdateGeometryInfo: menu resizing} { + set result {} + toplevel .t + frame .t.f -width 150 -height 50 -bg red + pack .t.f + wm geom .t -0-0 + update + set y [winfo rooty .t] + lappend result [winfo height .t] + menu .t.m + .t conf -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]] + destroy .t + set result +} {50 50 0} diff --git a/tests/window.test b/tests/window.test new file mode 100644 index 0000000..aaa29c0 --- /dev/null +++ b/tests/window.test @@ -0,0 +1,131 @@ +# This file is a Tcl script to test the procedures in the file +# tkWindow.c. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) window.test 1.8 97/01/22 14:17:54 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . +update + +# XXX This file is woefully incomplete. Right now it only tests +# a few parts of a few procedures in tkWindow.c + +test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} { + proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] + } + set x unchanged + catch {destroy .t} + frame .t -width 100 -height 50 + place .t -x 10 -y 10 + bind .t <Destroy> {button .t.b -text hello; pack .t.b} + update + destroy .t + update + rename bgerror {} + set x +} {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed + while executing +"button .t.b -text hello" + (command bound to event)}} + +# Most of the tests below don't produce meaningful results; they +# will simply dump core if there are bugs. + +test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} { + toplevel .t -width 300 -height 200 + wm geometry .t +0+0 + frame .t.f -width 200 -height 200 -relief raised -bd 2 + place .t.f -x 0 -y 0 + frame .t.f.f -width 100 -height 100 -relief raised -bd 2 + place .t.f.f -relx 1 -rely 1 -anchor se + bind .t.f <Destroy> {destroy .t} + update + destroy .t.f +} {} +test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} { + toplevel .t -width 300 -height 200 + wm geometry .t +0+0 + frame .t.f -width 200 -height 200 -relief raised -bd 2 + place .t.f -x 0 -y 0 + frame .t.f.f -width 100 -height 100 -relief raised -bd 2 + place .t.f.f -relx 1 -rely 1 -anchor se + bind .t.f.f <Destroy> {destroy .t} + update + destroy .t.f +} {} +test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { + frame .f -width 80 -height 120 -relief raised -bd 2 + place .f -relx 0.5 -rely 0.5 -anchor center + toplevel .f.t -width 300 -height 200 + wm geometry .f.t +0+0 + frame .f.t.f -width 200 -height 200 -relief raised -bd 2 + place .f.t.f -x 0 -y 0 + frame .f.t.f.f -width 100 -height 100 -relief raised -bd 2 + place .f.t.f.f -relx 1 -rely 1 -anchor se + update + destroy .f +} {} + +test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly { + catch {destroy .t} + toplevel .t -width 300 -height 200 + wm geometry .t +0+0 + pack [entry .t.e] + frame .t.f -bd 2 -relief raised + testmenubar window .t .t.f + update + # If stacking order isn't handle properly, generates an X error. +} {} +test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly { + catch {destroy .t} + toplevel .t -width 300 -height 200 + wm geometry .t +0+0 + pack [entry .t.e] + pack [entry .t.e2] + update + frame .t.f -bd 2 -relief raised + raise .t.f .t.e + testmenubar window .t .t.f + update + # If stacking order isn't handled properly, generates an X error. +} {} + +test window-4.1 {Tk_NameToWindow procedure} { + catch {destroy .t} + list [catch {winfo geometry .t} msg] $msg +} {1 {bad window path name ".t"}} +test window-4.2 {Tk_NameToWindow procedure} { + catch {destroy .t} + frame .t -width 100 -height 50 + place .t -x 10 -y 10 + update + list [catch {winfo geometry .t} msg] $msg +} {0 100x50+10+10} + +test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly { + catch {destroy .t} + toplevel .t -width 300 -height 200 + wm geometry .t +0+0 + pack [entry .t.e] + pack [entry .t.e2] + frame .t.f -bd 2 -relief raised + testmenubar window .t .t.f + update + lower .t.e2 .t.f + update + # If stacking order isn't handled properly, generates an X error. +} {} diff --git a/tests/winfo.test b/tests/winfo.test new file mode 100644 index 0000000..5d7292f --- /dev/null +++ b/tests/winfo.test @@ -0,0 +1,361 @@ +# This file is a Tcl script to test out the "winfo" command. It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winfo.test 1.19 97/05/16 08:49:01 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + catch {destroy $i} +} +wm geometry . {} +raise . + +# eatColors -- +# Creates a toplevel window and allocates enough colors in it to +# use up all the slots in the colormap. +# +# Arguments: +# w - Name of toplevel window to create. +# options - Options for w, such as "-colormap new". + +proc eatColors {w {options ""}} { + catch {destroy $w} + eval toplevel $w $options + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] + $w.c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } + } + update +} + +# XXX - This test file is woefully incomplete. At present, only a +# few of the winfo options are tested. + +test winfo-1.1 {"winfo atom" command} { + list [catch {winfo atom} msg] $msg +} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} +test winfo-1.2 {"winfo atom" command} { + list [catch {winfo atom a b} msg] $msg +} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} +test winfo-1.3 {"winfo atom" command} { + list [catch {winfo atom a b c d} msg] $msg +} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} +test winfo-1.4 {"winfo atom" command} { + list [catch {winfo atom -displayof geek foo} msg] $msg +} {1 {bad window path name "geek"}} +test winfo-1.5 {"winfo atom" command} { + winfo atom PRIMARY +} 1 +test winfo-1.6 {"winfo atom" command} { + winfo atom -displayof . PRIMARY +} 1 + +test winfo-2.1 {"winfo atomname" command} { + list [catch {winfo atomname} msg] $msg +} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}} +test winfo-2.2 {"winfo atomname" command} { + list [catch {winfo atomname a b} msg] $msg +} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}} +test winfo-2.3 {"winfo atomname" command} { + list [catch {winfo atomname a b c d} msg] $msg +} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}} +test winfo-2.4 {"winfo atomname" command} { + list [catch {winfo atomname -displayof geek foo} msg] $msg +} {1 {bad window path name "geek"}} +test winfo-2.5 {"winfo atomname" command} { + list [catch {winfo atomname 44215} msg] $msg +} {1 {no atom exists with id "44215"}} +test winfo-2.6 {"winfo atomname" command} { + winfo atomname 2 +} SECONDARY +test winfo-2.7 {"winfo atom" command} { + winfo atomname -displayof . 2 +} SECONDARY + +if {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")} { + test winfo-3.1 {"winfo colormapfull" command} { + list [catch {winfo colormapfull} msg] $msg + } {1 {wrong # args: should be "winfo colormapfull window"}} + test winfo-3.2 {"winfo colormapfull" command} { + list [catch {winfo colormapfull a b} msg] $msg + } {1 {wrong # args: should be "winfo colormapfull window"}} + test winfo-3.3 {"winfo colormapfull" command} { + list [catch {winfo colormapfull foo} msg] $msg + } {1 {bad window path name "foo"}} + test winfo-3.4 {"winfo colormapfull" command} {macOrUnix} { + eatColors .t {-colormap new} + set result [list [winfo colormapfull .] [winfo colormapfull .t]] + .t.c delete 34 + lappend result [winfo colormapfull .t] + .t.c create rectangle 30 30 80 80 -fill #441739 + lappend result [winfo colormapfull .t] + .t.c create rectangle 40 40 90 90 -fill #ffeedd + lappend result [winfo colormapfull .t] + destroy .t.c + lappend result [winfo colormapfull .t] + } {0 1 0 0 1 0} + catch {destroy .t} +} + +catch {destroy .t} +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 +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"}} +test winfo-4.2 {"winfo containing" command} { + list [catch {winfo containing a b c} msg] $msg +} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}} +test winfo-4.3 {"winfo containing" command} { + list [catch {winfo containing a b c d e} msg] $msg +} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}} +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} { + winfo containing [winfo rootx .t.f] [winfo rooty .t.f] +} .t.f +test winfo-4.6 {"winfo containing" command} {nonPortable} { + winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1] +} .t +test winfo-4.7 {"winfo containing" command} { + set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \ + [expr [winfo rooty .t.f]+450]] + expr {($x == ".") || ($x == "")} +} {1} +destroy .t + +test winfo-5.1 {"winfo interps" command} { + list [catch {winfo interps a} msg] $msg +} {1 {wrong # args: should be "winfo interps ?-displayof window?"}} +test winfo-5.2 {"winfo interps" command} { + list [catch {winfo interps a b c} msg] $msg +} {1 {wrong # args: should be "winfo interps ?-displayof window?"}} +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} { + expr [lsearch -exact [winfo interps] [tk appname]] >= 0 +} {1} +test winfo-5.5 {"winfo interps" command} {unixOnly} { + expr [lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0 +} {1} + +test winfo-6.1 {"winfo exists" command} { + list [catch {winfo exists} msg] $msg +} {1 {wrong # args: should be "winfo exists window"}} +test winfo-6.2 {"winfo exists" command} { + list [catch {winfo exists a b} msg] $msg +} {1 {wrong # args: should be "winfo exists window"}} +test winfo-6.3 {"winfo exists" command} { + winfo exists gorp +} {0} +test winfo-6.4 {"winfo exists" command} { + winfo exists . +} {1} +test winfo-6.5 {"winfo exists" command} { + button .b -text "Test button" + set x [winfo exists .b] + pack .b + update + bind .b <Destroy> {lappend x [winfo exists .x]} + destroy .b + lappend x [winfo exists .x] +} {1 0 0} + +catch {destroy .b} +button .b -text "Help" +update +test winfo-7.1 {"winfo pathname" command} { + list [catch {winfo pathname} msg] $msg +} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}} +test winfo-7.2 {"winfo pathname" command} { + list [catch {winfo pathname a b} msg] $msg +} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}} +test winfo-7.3 {"winfo pathname" command} { + list [catch {winfo pathname a b c d} msg] $msg +} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}} +test winfo-7.4 {"winfo pathname" command} { + list [catch {winfo pathname -displayof geek 25} msg] $msg +} {1 {bad window path name "geek"}} +test winfo-7.5 {"winfo pathname" command} { + list [catch {winfo pathname xyz} msg] $msg +} {1 {expected integer but got "xyz"}} +test winfo-7.6 {"winfo pathname" command} { + list [catch {winfo pathname 224} msg] $msg +} {1 {window id "224" doesn't exist in this application}} +test winfo-7.7 {"winfo pathname" command} { + winfo pathname -displayof .b [winfo id .] +} {.} +test winfo-7.8 {"winfo pathname" command} {unixOnly} { + winfo pathname [testwrapper .] +} {} + +test winfo-8.1 {"winfo pointerx" command} { + catch [winfo pointerx .b] +} 1 +test winfo-8.2 {"winfo pointery" command} { + catch [winfo pointery .b] +} 1 +test winfo-8.3 {"winfo pointerxy" command} { + catch [winfo pointerxy .b] +} 1 + +test winfo-9.1 {"winfo viewable" command} { + list [catch {winfo viewable} msg] $msg +} {1 {wrong # args: should be "winfo viewable window"}} +test winfo-9.2 {"winfo viewable" command} { + list [catch {winfo viewable foo} msg] $msg +} {1 {bad window path name "foo"}} +test winfo-9.3 {"winfo viewable" command} { + winfo viewable . +} {1} +test winfo-9.4 {"winfo viewable" command} { + wm iconify . + winfo viewable . +} {0} +wm deiconify . +test winfo-9.5 {"winfo viewable" command} { + frame .f1 -width 100 -height 100 -relief raised -bd 2 + place .f1 -x 0 -y 0 + frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 + place .f1.f2 -x 0 -y 0 + update + list [winfo viewable .f1] [winfo viewable .f1.f2] +} {1 1} +test winfo-9.6 {"winfo viewable" command} { + eval destroy [winfo child .] + frame .f1 -width 100 -height 100 -relief raised -bd 2 + frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 + place .f1.f2 -x 0 -y 0 + update + list [winfo viewable .f1] [winfo viewable .f1.f2] +} {0 0} +test winfo-9.7 {"winfo viewable" command} { + eval destroy [winfo child .] + frame .f1 -width 100 -height 100 -relief raised -bd 2 + place .f1 -x 0 -y 0 + frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 + place .f1.f2 -x 0 -y 0 + update + wm iconify . + list [winfo viewable .f1] [winfo viewable .f1.f2] +} {0 0} +wm deiconify . +eval destroy [winfo child .] + +test winfo-10.1 {"winfo visualid" command} { + list [catch {winfo visualid} msg] $msg +} {1 {wrong # args: should be "winfo visualid window"}} +test winfo-10.2 {"winfo visualid" command} { + list [catch {winfo visualid gorp} msg] $msg +} {1 {bad window path name "gorp"}} +test winfo-10.3 {"winfo visualid" command} { + expr 2+[winfo visualid .]-[winfo visualid .] +} {2} + +test winfo-11.1 {"winfo visualid" command} { + list [catch {winfo visualsavailable} msg] $msg +} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}} +test winfo-11.2 {"winfo visualid" command} { + list [catch {winfo visualsavailable gorp} msg] $msg +} {1 {bad window path name "gorp"}} +test winfo-11.3 {"winfo visualid" command} { + list [catch {winfo visualsavailable . includeids foo} msg] $msg +} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}} +test winfo-11.4 {"winfo visualid" command} { + llength [lindex [winfo visualsa .] 0] +} {2} +test winfo-11.5 {"winfo visualid" command} { + llength [lindex [winfo visualsa . includeids] 0] +} {3} +test winfo-11.6 {"winfo visualid" command} { + set x [lindex [lindex [winfo visualsa . includeids] 0] 2] + expr $x + 2 - $x +} {2} + +test winfo-12.1 {GetDisplayOf procedure} { + list [catch {winfo atom - foo x} msg] $msg +} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} +test winfo-12.2 {GetDisplayOf procedure} { + list [catch {winfo atom -d bad_window x} msg] $msg +} {1 {bad window path name "bad_window"}} + +# Some embedding tests +# + +proc MakeEmbed {} { + frame .con -container 1 + pack .con -expand yes -fill both + toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 + button .emb.b + pack .emb.b -expand yes -fill both + update +} +test winfo-13.1 {root coordinates of embedded toplevel} {macOrUnix} { + MakeEmbed + set z [expr [winfo rootx .emb] == [winfo rootx .con] && \ + [winfo rooty .emb] == [winfo rooty .con]] + destroy .emb + destroy .con + set z +} {1} +test winfo-13.2 {destroying embedded toplevel} {macOrUnix} { + catch {destroy .emb} + update + expr [winfo exists .emb.b] || [winfo exists .con] +} 0 + +foreach i [winfo children .] { + destroy $i +} + +test winfo-13.3 {destroying container window} {macOrUnix} { + MakeEmbed + destroy .con + update + set z [expr [winfo exists .emb.b] || [winfo exists .emb]] + catch {destroy .emb} + catch {destroy .con} + set z +} 0 + +foreach i [winfo children .] { + destroy $i +} + +test winfo-13.4 {[winfo containing] with embedded windows} {macOrUnix} { + MakeEmbed + button .b + pack .b -expand yes -fill both + update + + set z [string compare \ + [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] .emb.b] + catch {destroy .con} + catch {destroy .emb} + set z +} 0 + +foreach i [winfo children .] { + catch {destroy $i} +} |