ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import Tk 8.6.6 (as of svn r86089)

Browse Source
This commit is contained in:
Zachary Ware
2017-05-22 16:13:37 -05:00
parent d239d63057
commit b1c28856bb
899 changed files with 545127 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
tests/README Normal file
View File

@@ -0,0 +1,5 @@
README -- Tk test suite design document.
This directory contains a set of validation tests for the Tk commands.
Please see the tests/README file in the Tcl source distribution for
information about the test suite.

19
tests/all.tcl Normal file
View File

@@ -0,0 +1,19 @@
# all.tcl --
#
# This file contains a top-level script to run all of the Tk
# tests. Execute it by invoking "source all.tcl" when running tktest
# in this directory.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tk ;# This is the Tk test suite; fail early if no Tk!
package require tcltest 2.2
tcltest::configure {*}$argv
tcltest::configure -testdir [file normalize [file dirname [info script]]]
tcltest::configure -loadfile \
[file join [tcltest::testsDirectory] constraints.tcl]
tcltest::configure -singleproc 1
tcltest::runAllTests

151
tests/arc.tcl Normal file
View File

@@ -0,0 +1,151 @@
# This file creates a visual test for arcs. It is part of the Tk
# visual test suite, which is invoked via the "visual" script.
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}

53
tests/bell.test Normal file
View File

@@ -0,0 +1,53 @@
# 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) 1998-2000 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test bell-1.1 {bell command} -body {
bell a
} -returnCodes {error} -result {bad option "a": must be -displayof or -nice}
test bell-1.2 {bell command} -body {
bell a b
} -returnCodes {error} -result {bad option "a": must be -displayof or -nice}
test bell-1.3 {bell command} -body {
bell -displayof gorp
} -returnCodes {error} -result {bad window path name "gorp"}
test bell-1.4 {bell command} -body {
bell -nice -displayof
} -returnCodes {error} -result {wrong # args: should be "bell ?-displayof window? ?-nice?"}
test bell-1.5 {bell command} -body {
bell -nice -nice -nice
} -returnCodes {ok} -result {} ;#keep -result {} and -retutnCodes {ok} for clarity?
test bell-1.6 {bell command} -body {
bell -displayof . -nice
} -returnCodes {ok} -result {}
test bell-1.7 {bell command} -body {
bell -nice -displayof . -nice
} -returnCodes {error} -result {wrong # args: should be "bell ?-displayof window? ?-nice?"}
test bell-1.8 {bell command} -body {
puts "Bell should ring now ..."
flush stdout
after 200
bell -displayof .
after 200
bell -nice
after 200
bell
} -result {}
cleanupTests
return

158
tests/bevel.tcl Normal file
View File

@@ -0,0 +1,158 @@
# 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.
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
S - should appear solid
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
font configure TkFixedFont -size 20
.t.t tag configure sol100 -relief solid -borderwidth 100 \
-foreground red -font TkFixedFont
.t.t tag configure sol12 -relief solid -borderwidth 12 \
-foreground red -font TkFixedFont
.t.t tag configure big -font TkFixedFont
set ind [.t.t index end]
.t.t insert end "\n\nBorders do not leak on the neighbour chars"
.t.t insert end "\nOnly \"S\" is on dark background"
.t.t insert end {
xxx
x} {} S sol100 {x
xxx}
.t.t insert end "\n\nA very thick border grows toward the inside of the tagged area only"
.t.t insert end "\nOnly \"S\" is on dark background"
.t.t insert end {
xxxx} {} SSSSS sol100 {xxxx
x} {} SSSSSSSSSSSSSSSSSS sol100 {x
xxx} {} SSSSSSSSS sol100 xxxx {}
.t.t insert end "\n\nA thinner border is continuous"
.t.t insert end {
xxxx} {} SSSSS sol12 {xxxx
x} {} SSSSSSSSSSSSSSSSSS sol12 {x
xxx} {} SSSSSSSSS sol12 xxxx {}
.t.t tag add big $ind end

67
tests/bgerror.test Normal file
View File

@@ -0,0 +1,67 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test bgerror-1.1 {bgerror / tkerror compat} -setup {
set errRes {}
proc tkerror {err} {
global errRes;
set errRes $err;
}
} -body {
after 0 {error err1}
vwait errRes;
return $errRes;
} -cleanup {
catch {rename tkerror {}}
} -result {err1}
test bgerror-1.2 {bgerror / tkerror compat / accumulation} -setup {
set errRes {}
proc tkerror {err} {
global errRes;
lappend errRes $err;
}
} -body {
after 0 {error err1}
after 0 {error err2}
after 0 {error err3}
update
return $errRes;
} -cleanup {
catch {rename tkerror {}}
} -result {err1 err2 err3}
test bgerror-1.3 {bgerror / tkerror compat / accumulation / break} -setup {
set errRes {}
proc tkerror {err} {
global errRes;
lappend errRes $err;
return -code break "skip!";
}
} -body {
after 0 {error err1}
after 0 {error err2}
after 0 {error err3}
update
return $errRes;
} -cleanup {
catch {rename tkerror {}}
} -result {err1}
# some testing of the default error dialog
# would be needed too, but that's not easy at all
# to emulate.
# cleanup
cleanupTests
return

6124
tests/bind.test Normal file
View File

File diff suppressed because it is too large Load Diff

111
tests/bitmap.test Normal file
View File

@@ -0,0 +1,111 @@
# This file is a Tcl script to test out the procedures in the file
# tkBitmap.c. It is organized in the standard white-box fashion for
# Tcl tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} -constraints {
testbitmap
} -body {
set x gray25
lindex $x 0
button .b -bitmap $x
lindex $x 0
testbitmap gray25
} -cleanup {
destroy .b
} -result {{1 0}}
test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} -constraints {
testbitmap
} -setup {
set result {}
} -body {
set x gray25
button .b1 -bitmap $x
destroy .b1
lappend result [testbitmap gray25]
button .b2 -bitmap $x
lappend result [testbitmap gray25]
} -cleanup {
destroy .b1 .b2
} -result {{} {{1 1}}}
test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} -constraints {
testbitmap
} -setup {
set result {}
} -body {
set x gray25
button .b1 -bitmap $x
lappend result [testbitmap gray25]
button .b2 -bitmap $x
pack .b1 .b2 -side top
lappend result [testbitmap gray25]
} -cleanup {
destroy .b1 .b2
} -result {{{1 1}} {{2 1}}}
test bitmap-2.1 {Tk_GetBitmap procedure} -body {
button .b1 -bitmap bad_name
} -cleanup {
destroy .b1
} -returnCodes error -result {bitmap "bad_name" not defined}
test bitmap-2.2 {Tk_GetBitmap procedure} -body {
button .b1 -bitmap @xyzzy
} -cleanup {
destroy .b1
} -returnCodes error -result {error reading bitmap file "xyzzy"}
test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} -constraints {
testbitmap
} -setup {
set result {}
} -body {
set x questhead
button .b1 -bitmap $x
button .b3 -bitmap $x
button .b2 -bitmap $x
lappend result [testbitmap questhead]
destroy .b1
lappend result [testbitmap questhead]
destroy .b2
lappend result [testbitmap questhead]
destroy .b3
lappend result [testbitmap questhead]
} -cleanup {
destroy .b1 .b2 .b3 ;# destroying just in case
} -result {{{3 1}} {{2 1}} {{1 1}} {}}
test bitmap-4.1 {FreeBitmapObjProc} -constraints {
testbitmap
} -body {
set x [join questhead]
button .b -bitmap $x
set y [join questhead]
.b configure -bitmap $y
set z [join questhead]
.b configure -bitmap $z
set result {}
lappend result [testbitmap questhead]
set x red
lappend result [testbitmap questhead]
set z 32
lappend result [testbitmap questhead]
destroy .b
lappend result [testbitmap questhead]
set y bogus
return $result
} -cleanup {
destroy .b
} -result {{{1 3}} {{1 2}} {{1 1}} {}}
# cleanup
cleanupTests
return

199
tests/border.test Normal file
View File

@@ -0,0 +1,199 @@
# This file is a Tcl script to test out the procedures in the file
# tkBorder.c. It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints {
testborder
} -body {
set x orange
lindex $x 0
button .b1 -bg $x -text .b1
lindex $x 0
testborder orange
} -cleanup {
destroy .b1
} -result {{1 0}}
test border-1.2 {Tk_AllocBorderFromObj - discard stale border} -constraints {
testborder
} -setup {
set result {}
} -body {
set x orange
button .b1 -bg $x -text First
destroy .b1
lappend result [testborder orange]
button .b2 -bg $x -text Second
lappend result [testborder orange]
} -cleanup {
destroy .b1 .b2
} -result {{} {{1 1}}}
test border-1.3 {Tk_AllocBorderFromObj - reuse existing border} -constraints {
testborder
} -setup {
set result {}
} -body {
set x orange
button .b1 -bg $x -text First
lappend result [testborder orange]
button .b2 -bg $x -text Second
pack .b1 .b2 -side top
lappend result [testborder orange]
} -cleanup {
destroy .b1 .b2
} -result {{{1 1}} {{2 1}}}
test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} -constraints {
testborder pseudocolor8
} -setup {
toplevel .t -visual {pseudocolor 8} -colormap new
wm geom .t +0+0
set result {}
} -body {
set x purple
button .b1 -bg $x -text First
pack .b1 -side top
lappend result [testborder purple]
button .t.b -bg $x -text Second
pack .t.b -side top
lappend result [testborder purple]
button .b2 -bg $x -text Third
pack .b2 -side top
lappend result [testborder purple]
} -cleanup {
destroy .b1 .b2 .t
} -result {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
test border-2.1 {Tk_Free3DBorder - reference counts} -constraints {
testborder pseudocolor8
} -setup {
toplevel .t -visual {pseudocolor 8} -colormap new
wm geom .t +0+0
set result {}
} -body {
set x purple
button .b1 -bg $x -text First
pack .b1 -side top
button .t.b -bg $x -text Second
pack .t.b -side top
button .b2 -bg $x -text Third
pack .b2 -side top
lappend result [testborder purple]
destroy .b1
lappend result [testborder purple]
destroy .b2
lappend result [testborder purple]
destroy .t.b
lappend result [testborder purple]
} -cleanup {
destroy .b1 .b2 .t
} -result {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
test border-2.2 {Tk_Free3DBorder - unlinking from list} -constraints {
testborder pseudocolor8
} -setup {
toplevel .t -visual {pseudocolor 8} -colormap new
wm geom .t +0+0
toplevel .t2 -visual {pseudocolor 8} -colormap new
toplevel .t3 -visual {pseudocolor 8} -colormap new
set result {}
} -body {
set x purple
button .b -bg $x -text .b1
button .t.b1 -bg $x -text .t.b1
button .t.b2 -bg $x -text .t.b2
button .t2.b1 -bg $x -text .t2.b1
button .t2.b2 -bg $x -text .t2.b2
button .t2.b3 -bg $x -text .t2.b3
button .t3.b1 -bg $x -text .t3.b1
button .t3.b2 -bg $x -text .t3.b2
button .t3.b3 -bg $x -text .t3.b3
button .t3.b4 -bg $x -text .t3.b4
lappend result [testborder purple]
destroy .t2
lappend result [testborder purple]
destroy .b
lappend result [testborder purple]
destroy .t3
lappend result [testborder purple]
destroy .t
lappend result [testborder purple]
} -cleanup {
destroy .b .t2 .t3 .t
} -result {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
test border-3.1 {FreeBorderObjProc} -constraints {
testborder
} -setup {
set result {}
} -body {
set x [join purple]
button .b -bg $x -text .b1
set y [join purple]
.b configure -bg $y
set z [join purple]
.b configure -bg $z
lappend result [testborder purple]
set x red
lappend result [testborder purple]
set z 32
lappend result [testborder purple]
destroy .b
lappend result [testborder purple]
set y bogus
return $result
} -cleanup {
destroy .b
} -result {{{1 3}} {{1 2}} {{1 1}} {}}
test border-4.1 {Tk_GetReliefFromObj} -body {
button .b -relief flat
.b cget -relief
} -cleanup {
destroy .b
} -result {flat}
test border-4.2 {Tk_GetReliefFromObj} -body {
button .b -relief groove
.b cget -relief
} -cleanup {
destroy .b
} -result {groove}
test border-4.3 {Tk_GetReliefFromObj} -body {
button .b -relief raised
.b cget -relief
} -cleanup {
destroy .b
} -result {raised}
test border-4.4 {Tk_GetReliefFromObj} -body {
button .b -relief ridge
.b cget -relief
} -cleanup {
destroy .b
} -result {ridge}
test border-4.5 {Tk_GetReliefFromObj} -body {
button .b -relief solid
.b cget -relief
} -cleanup {
destroy .b
} -result {solid}
test border-4.6 {Tk_GetReliefFromObj} -body {
button .b -relief sunken
.b cget -relief
} -cleanup {
destroy .b
} -result {sunken}
test border-4.7 {Tk_GetReliefFromObj - error} -body {
button .b -relief upanddown
} -cleanup {
destroy .b
} -returnCodes error -result {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}
# cleanup
cleanupTests
return

41
tests/bugs.tcl Normal file
View File

@@ -0,0 +1,41 @@
# 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.
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 ""
} {}

477
tests/busy.test Normal file
View File

@@ -0,0 +1,477 @@
# Tests for the tk busy command.
#
# This file contains a collection of tests for one or more of the Tk built-in
# commands. Sourcing this file runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1998-2000 by Jos Decoster. All rights reserved.
package require tcltest 2.1
tcltest::configure {*}$argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
# There's currently no way to test the actual grab effect, per se, in an
# automated test. Therefore, this test suite only covers the interface to the
# grab command (ie, error messages, etc.)
test busy-1.1 {Tk_BusyObjCmd} -returnCodes error -body {
tk busy
} -result {wrong # args: should be "tk busy options ?arg arg ...?"}
test busy-2.1 {tk busy hold} -returnCodes error -body {
tk busy hold
} -result {wrong # args: should be "tk busy hold window ?option value ...?"}
test busy-2.2 {tk busy hold root window} -body {
tk busy hold .
update
} -cleanup {
tk busy forget .
} -result {}
test busy-2.3 {tk busy hold root window with shortcut} -body {
tk busy .
update
} -cleanup {
tk busy forget .
} -result {}
test busy-2.4 {tk busy hold nested window} -setup {
pack [frame .f]
} -body {
tk busy hold .f
update
} -cleanup {
tk busy forget .f
destroy .f
} -result {}
test busy-2.5 {tk busy hold nested window with shortcut} -setup {
pack [frame .f]
} -body {
tk busy .f
update
} -cleanup {
tk busy forget .f
destroy .f
} -result {}
test busy-2.6 {tk busy hold toplevel window} -setup {
toplevel .f
} -body {
tk busy hold .f
update
} -cleanup {
tk busy forget .f
destroy .f
} -result {}
test busy-2.7 {tk busy hold toplevel window with shortcut} -setup {
toplevel .f
} -body {
tk busy .f
update
} -cleanup {
tk busy forget .f
destroy .f
} -result {}
test busy-2.8 {tk busy hold non existing window} -body {
tk busy hold .f
update
} -returnCodes error -result {bad window path name ".f"}
test busy-2.9 {tk busy hold (shortcut) non existing window} -body {
tk busy .f
update
} -returnCodes {error} -result {bad window path name ".f"}
test busy-2.10 {tk busy hold root window with cursor} -body {
tk busy hold . -cursor arrow
update
} -cleanup {
tk busy forget .
} -result {}
test busy-2.11 {tk busy hold (shortcut) root window, cursor} -body {
tk busy . -cursor arrow
update
} -cleanup {
tk busy forget .
} -result {}
test busy-2.12 {tk busy hold root window, invalid cursor} -body {
tk busy hold . -cursor nonExistingCursor
update
} -constraints tempNotMac -returnCodes error -cleanup {
tk busy forget .
} -result {bad cursor spec "nonExistingCursor"}
test busy-2.13 {tk busy hold (shortcut) root window, invalid cursor} -body {
tk busy . -cursor nonExistingCursor
update
} -constraints tempNotMac -returnCodes error -cleanup {
tk busy forget .
} -result {bad cursor spec "nonExistingCursor"}
test busy-2.14 {tk busy hold root window, invalid option} -body {
tk busy hold . -invalidOption 1
update
} -constraints tempNotMac -returnCodes error -cleanup {
tk busy forget .
} -result {unknown option "-invalidOption"}
test busy-2.15 {tk busy hold (shortcut) root window, invalid option} -body {
tk busy . -invalidOption 1
update
} -constraints tempNotMac -returnCodes error -cleanup {
tk busy forget .
} -result {unknown option "-invalidOption"}
test busy-3.1 {tk busy cget no window} -returnCodes error -body {
tk busy cget
} -result {wrong # args: should be "tk busy cget window option"}
test busy-3.2 {tk busy cget no option} -returnCodes error -body {
tk busy cget
} -result {wrong # args: should be "tk busy cget window option"}
test busy-3.3 {tk busy cget invalid window} -returnCodes error -body {
tk busy cget .f -cursor
} -result {bad window path name ".f"}
test busy-3.4 {tk busy cget non-busy window} -setup {
pack [frame .f]
} -body {
tk busy cget .f -cursor
} -cleanup {
destroy .f
} -returnCodes error -result {can't find busy window ".f"}
test busy-3.5 {tk busy cget invalid option} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy cget .f -invalidOption
} -cleanup {
tk busy forget .f
destroy .f
} -returnCodes error -result {unknown option "-invalidOption"}
test busy-3.6unix {tk busy cget unix} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy cget .f -cursor
} -cleanup {
tk busy forget .f
destroy .f
} -result {watch} -constraints unix
test busy-3.6win {tk busy cget win} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy cget .f -cursor
} -cleanup {
tk busy forget .f
destroy .f
} -result {wait} -constraints win
test busy-3.7 {tk busy cget unix} -setup {
pack [frame .f]
tk busy hold .f -cursor hand1
update
} -body {
tk busy cget .f -cursor
} -cleanup {
tk busy forget .f
destroy .f
} -result {hand1} -constraints tempNotMac
test busy-4.1 {tk busy configure no window} -returnCodes error -body {
tk busy configure
} -result {wrong # args: should be "tk busy configure window ?option? ?value ...?"}
test busy-4.2 {tk busy configure invalid window} -body {
tk busy configure .f
} -returnCodes error -result {bad window path name ".f"}
test busy-4.3 {tk busy configure non-busy window} -setup {
pack [frame .f]
} -body {
tk busy configure .f
} -cleanup {
destroy .f
} -returnCodes error -result {can't find busy window ".f"}
test busy-4.4 {tk busy configure} -constraints {nonwin} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy configure .f
} -cleanup {
tk busy forget .f
destroy .f
} -result {{-cursor cursor Cursor watch watch}}
test busy-4.4-win {tk busy configure} -constraints {win} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy configure .f
} -cleanup {
tk busy forget .f
destroy .f
} -result {{-cursor cursor Cursor wait wait}}
test busy-4.5 {tk busy configure} -constraints {nonwin tempNotMac} -setup {
pack [frame .f]
tk busy hold .f -cursor hand2
update
} -body {
tk busy configure .f
} -cleanup {
tk busy forget .f
destroy .f
} -result {{-cursor cursor Cursor watch hand2}}
test busy-4.5-win {tk busy configure} -constraints win -setup {
pack [frame .f]
tk busy hold .f -cursor hand2
update
} -body {
tk busy configure .f
} -cleanup {
tk busy forget .f
destroy .f
} -result {{-cursor cursor Cursor wait hand2}}
test busy-4.6 {tk busy configure invalid option} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy configure .f -invalidOption
} -cleanup {
tk busy forget .f
destroy .f
} -returnCodes error -result {unknown option "-invalidOption"}
test busy-4.7 {tk busy configure valid option} -constraints {nonwin} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy configure .f -cursor
} -cleanup {
tk busy forget .f
destroy .f
} -result {-cursor cursor Cursor watch watch}
test busy-4.7-win {tk busy configure valid option} -constraints {win} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy configure .f -cursor
} -cleanup {
tk busy forget .f
destroy .f
} -result {-cursor cursor Cursor wait wait}
test busy-4.8 {tk busy configure valid option} -constraints {
nonwin tempNotMac
} -setup {
pack [frame .f]
tk busy hold .f -cursor circle
update
} -body {
tk busy configure .f -cursor
} -cleanup {
tk busy forget .f
destroy .f
} -result {-cursor cursor Cursor watch circle}
test busy-4.8-win {tk busy configure valid option} -constraints win -setup {
pack [frame .f]
tk busy hold .f -cursor circle
update
} -body {
tk busy configure .f -cursor
} -cleanup {
tk busy forget .f
destroy .f
} -result {-cursor cursor Cursor wait circle}
test busy-4.9 {tk busy configure valid option with value} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy configure .f -cursor pencil
tk busy cget .f -cursor
} -cleanup {
tk busy forget .f
destroy .f
} -result {pencil} -constraints tempNotMac
test busy-4.10 {tk busy configure valid option with invalid value} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy configure .f -cursor nonExistingCursor
} -constraints tempNotMac -returnCodes error -cleanup {
tk busy forget .f
destroy .f
} -result {bad cursor spec "nonExistingCursor"}
test busy-5.1 {tk busy forget} -returnCodes error -body {
tk busy forget
} -result {wrong # args: should be "tk busy forget window"}
test busy-5.2 {tk busy forget non existing window} -body {
tk busy forget .f
} -returnCodes error -result {bad window path name ".f"}
test busy-5.3 {tk busy forget non busy window} -setup {
pack [frame .f]
} -body {
tk busy forget .f
} -cleanup {
destroy .f
} -returnCodes error -result {can't find busy window ".f"}
test busy-5.4 {tk busy forget window} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
set r [tk busy status .f]
tk busy forget .f
lappend r [tk busy status .f]
} -cleanup {
destroy .f
} -result {1 0}
test busy-6.1 {tk busy status} -returnCodes error -body {
tk busy status
} -result {wrong # args: should be "tk busy status window"}
test busy-6.2 {tk busy status non existing window} -body {
tk busy status .f
} -result {0}
test busy-6.3 {tk busy status non busy window} -setup {
pack [frame .f]
} -body {
tk busy status .f
} -cleanup {
destroy .f
} -result {0}
test busy-6.4 {tk busy status busy window} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy status .f
} -cleanup {
tk busy forget .f
destroy .f
} -result {1}
test busy-6.5 {tk busy status forgotten busy window} -setup {
pack [frame .f]
tk busy hold .f
update
tk busy forget .f
} -body {
tk busy status .f
} -cleanup {
destroy .f
} -result {0}
test busy-7.1 {tk busy current no busy} -body {
tk busy current
} -result {}
test busy-7.2 {tk busy current 1 busy} -setup {
pack [frame .f]
tk busy hold .f
update
} -body {
tk busy current
} -cleanup {
tk busy forget .f
destroy .f
} -result {.f}
test busy-7.3 {tk busy current 2 busy} -setup {
pack [frame .f1]
pack [frame .f2]
tk busy hold .f1
tk busy hold .f2
update
} -body {
lsort [tk busy current]
} -cleanup {
tk busy forget .f1
tk busy forget .f2
destroy .f1 .f2
} -result {.f1 .f2}
test busy-7.4 {tk busy current 2 busy with matching filter} -setup {
pack [frame .f1]
pack [frame .f2]
tk busy hold .f1
tk busy hold .f2
update
} -body {
lsort [tk busy current *2*]
} -cleanup {
tk busy forget .f1
tk busy forget .f2
destroy .f1 .f2
} -result {.f2}
test busy-7.5 {tk busy current 2 busy with non matching filter} -setup {
pack [frame .f1]
pack [frame .f2]
tk busy hold .f1
tk busy hold .f2
update
} -body {
lsort [tk busy current *3*]
} -cleanup {
tk busy forget .f1
tk busy forget .f2
destroy .f1 .f2
} -result {}
test busy-7.6 {tk busy current 1 busy after forget} -setup {
pack [frame .f]
tk busy hold .f
update
tk busy forget .f
} -body {
tk busy current
} -cleanup {
destroy .f
} -result {}
test busy-7.7 {tk busy current 2 busy after forget} -setup {
pack [frame .f1]
pack [frame .f2]
tk busy hold .f1
tk busy hold .f2
update
tk busy forget .f1
} -body {
lsort [tk busy current]
} -cleanup {
tk busy forget .f2
destroy .f1 .f2
} -result {.f2}
test busy-7.8 {tk busy current 2 busy with matching filter after forget} -setup {
pack [frame .f1]
pack [frame .f2]
tk busy hold .f1
tk busy hold .f2
update
tk busy forget .f1
} -body {
lsort [tk busy current *2*]
} -cleanup {
tk busy forget .f2
destroy .f1 .f2
} -result {.f2}
test busy-7.9 {tk busy current 2 busy with non matching filter after forget} -setup {
pack [frame .f1]
pack [frame .f2]
tk busy hold .f1
tk busy hold .f2
update
tk busy forget .f1
} -body {
lsort [tk busy current *3*]
} -cleanup {
tk busy forget .f2
destroy .f1 .f2
} -result {}
::tcltest::cleanupTests
return

126
tests/butGeom.tcl Normal file
View File

@@ -0,0 +1,126 @@
# 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.
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
}
}

124
tests/butGeom2.tcl Normal file
View File

@@ -0,0 +1,124 @@
# 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.
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
}
}

3935
tests/button.test Normal file
View File

File diff suppressed because it is too large Load Diff

796
tests/canvImg.test Normal file
View File

@@ -0,0 +1,796 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit
# Canvas used in every test case of the whole file
canvas .c
pack .c
update
test canvImg-1.1 {options for image items} -body {
.c create image 50 50 -anchor nw -tags i1
.c itemconfigure i1 -anchor
} -cleanup {
.c delete all
} -result {-anchor {} {} center nw}
test canvImg-1.2 {options for image items} -body {
.c create image 50 50 -anchor gorp -tags i1
} -cleanup {
.c delete all
} -returnCodes {error} -result {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}
test canvImg-1.3 {options for image items} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c create image 50 50 -image foo -tags i1
.c itemconfigure i1 -image
} -cleanup {
.c delete all
image delete foo
} -result {-image {} {} {} foo}
test canvImg-1.4 {options for image items} -body {
.c create image 50 50 -image unknown -tags i1
} -cleanup {
.c delete all
} -returnCodes {error} -result {image "unknown" doesn't exist}
test canvImg-1.5 {options for image items} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c create image 50 50 -image foo -tags {i1 foo}
.c itemconfigure i1 -tags
} -cleanup {
.c delete all
image delete foo
} -result {-tags {} {} {} {i1 foo}}
test canvImg-2.1 {CreateImage procedure} -body {
.c create image 40
} -cleanup {
.c delete all
} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
test canvImg-2.2 {CreateImage procedure} -body {
.c create image 40 50 60
} -cleanup {
.c delete all
} -returnCodes {error} -result {unknown option "60"}
test canvImg-2.3 {CreateImage procedure} -body {
.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]
} -cleanup {
.c delete all
} -result {center {} {}}
test canvImg-2.4 {CreateImage procedure} -body {
.c create image xyz 40
} -cleanup {
.c delete all
} -returnCodes {error} -result {bad screen distance "xyz"}
test canvImg-2.5 {CreateImage procedure} -body {
.c create image 50 qrs
} -cleanup {
.c delete all
} -returnCodes {error} -result {bad screen distance "qrs"}
test canvImg-2.6 {CreateImage procedure} -constraints testImageType -body {
.c create image 50 50 -gorp foo
} -cleanup {
.c delete all
} -returnCodes {error} -result {unknown option "-gorp"}
test canvImg-3.1 {ImageCoords procedure} -constraints testImageType -setup {
image create test foo
} -body {
.c create image 50 100 -image foo -tags i1
format {%.6g %.6g} {*}[.c coords i1]
} -cleanup {
.c delete all
image delete foo
} -result {50 100}
test canvImg-3.2 {ImageCoords procedure} -constraints testImageType -setup {
image create test foo
} -body {
.c create image 50 100 -image foo -tags i1
.c coords i1 dumb 100
} -cleanup {
.c delete all
image delete foo
} -returnCodes {error} -result {bad screen distance "dumb"}
test canvImg-3.3 {ImageCoords procedure} -constraints testImageType -setup {
image create test foo
} -body {
.c delete all
.c create image 50 100 -image foo -tags i1
.c coords i1 250 dumb0
} -cleanup {
.c delete all
image delete foo
} -returnCodes {error} -result {bad screen distance "dumb0"}
test canvImg-3.4 {ImageCoords procedure} -constraints testImageType -setup {
image create test foo
} -body {
.c delete all
.c create image 50 100 -image foo -tags i1
.c coords i1 250
} -cleanup {
.c delete all
image delete foo
} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
test canvImg-3.5 {ImageCoords procedure} -constraints testImageType -setup {
image create test foo
} -body {
.c delete all
.c create image 50 100 -image foo -tags i1
.c coords i1 250 300 400
} -cleanup {
.c delete all
image delete foo
} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3}
test canvImg-4.1 {ConfiugreImage procedure} -constraints testImageType -setup {
.c delete all
} -body {
image create test foo -variable x
.c create image 50 100 -image foo -tags i1
update
set x {}
.c itemconfigure i1 -image {}
update
list $x [.c bbox i1]
} -cleanup {
.c delete all
image delete foo
} -result {{{foo free}} {}}
test canvImg-4.2 {ConfiugreImage procedure} -constraints testImageType -setup {
.c delete all
} -body {
image create test foo -variable x
image create test foo2 -variable y
foo2 changed 0 0 0 0 80 60
.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]
} -cleanup {
.c delete all
image delete foo
image delete foo2
} -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}}
test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup {
.c delete all
} -body {
image create test foo -variable x
image create test foo2 -variable y
foo2 changed 0 0 0 0 80 60
.c create image 50 100 -image foo -tags i1 -anchor nw
update
set x {}
set y {}
.c itemconfigure i1 -image lousy
} -cleanup {
.c delete all
image delete foo foo2
} -returnCodes {error} -result {image "lousy" doesn't exist}
test canvImg-5.1 {DeleteImage procedure} -constraints testImageType -setup {
.c delete all
imageCleanup
} -body {
image create test foo -variable x
image create test foo2 -variable y
image create test xyzzy -variable z
.c create image 50 100 -image xyzzy -tags i1
update
set names [lsort [imageNames]]
image delete xyzzy
set z {}
set names2 [lsort [imageNames]]
.c delete i1
update
list $names $names2 $z [lsort [imageNames]]
} -cleanup {
imageCleanup
.c delete all
} -result {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}}
test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} -body {
.c delete all
.c create image 50 100 -tags i1
update
.c delete i1
update
} -result {}
test canvImg-6.1 {ComputeImageBbox procedure} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c create image 15.51 17.51 -image foo -tags i1 -anchor nw
.c bbox i1
} -cleanup {
.c delete all
imageCleanup
} -result {16 18 46 33}
test canvImg-6.2 {ComputeImageBbox procedure} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c create image 15.49 17.49 -image foo -tags i1 -anchor nw
.c bbox i1
} -cleanup {
.c delete all
imageCleanup
} -result {15 17 45 32}
test canvImg-6.3 {ComputeImageBbox procedure} -setup {
.c delete all
} -body {
.c create image 20 30 -tags i1 -anchor nw
.c bbox i1
} -cleanup {
.c delete all
} -result {}
test canvImg-6.4 {ComputeImageBbox procedure} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor nw
.c bbox i1
} -cleanup {
.c delete all
imageCleanup
} -result {20 30 50 45}
test canvImg-6.5 {ComputeImageBbox procedure} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor n
.c bbox i1
} -cleanup {
.c delete all
imageCleanup
} -result {5 30 35 45}
test canvImg-6.6 {ComputeImageBbox procedure} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor ne
.c bbox i1
} -cleanup {
.c delete all
imageCleanup
} -result {-10 30 20 45}
test canvImg-6.7 {ComputeImageBbox procedure} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor e
.c bbox i1
} -cleanup {
.c delete all
imageCleanup
} -result {-10 23 20 38}
test canvImg-6.8 {ComputeImageBbox procedure} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor se
.c bbox i1
} -cleanup {
.c delete all
imageCleanup
} -result {-10 15 20 30}
test canvImg-6.9 {ComputeImageBbox procedure} -constraints testImageType -setup {
image create test foo
.c delete all
} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor s
.c bbox i1
} -cleanup {
.c delete all
imageCleanup
} -result {5 15 35 30}
test canvImg-6.10 {ComputeImageBbox procedure} -constraints {
testImageType
} -setup {
image create test foo
.c delete all
} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor sw
.c bbox i1
} -cleanup {
.c delete all
image delete foo
} -result {20 15 50 30}
test canvImg-6.11 {ComputeImageBbox procedure} -constraints {
testImageType
} -setup {
image create test foo
.c delete all
} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor w
.c bbox i1
} -cleanup {
.c delete all
image delete foo
} -result {20 23 50 38}
test canvImg-6.12 {ComputeImageBbox procedure} -constraints {
testImageType
} -setup {
image create test foo
.c delete all
} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor center
.c bbox i1
} -cleanup {
.c delete all
image delete foo
} -result {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} -constraints {
nonPortable testImageType
} -setup {
.c delete all
} -body {
image create test foo -variable x
.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
} -result {{foo display 4 9 12 6 30 30}}
test canvImg-7.2 {DisplayImage procedure, no image} -body {
.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
} -result {}
# image used in 8.* test cases
if {[testConstraint testImageType]} {
image create test foo
}
test canvImg-8.1 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect 50 70 80 81
.c gettags [.c find closest 70 90]
} -cleanup {
.c delete all
} -result {rect}
test canvImg-8.2 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{50 70 80 79}
.c gettags [.c find closest {*}{70 90}]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.3 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{99 70 110 81}
.c gettags [.c find closest {*}{90 90}]
} -cleanup {
.c delete all
} -result {rect}
test canvImg-8.4 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{101 70 110 79}
.c gettags [.c find closest {*}{90 90}]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.5 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{99 100 110 115}
.c gettags [.c find closest {*}{90 110}]
} -cleanup {
.c delete all
} -result {rect}
test canvImg-8.6 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{101 100 110 115}
.c gettags [.c find closest {*}{90 110}]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.7 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{99 134 110 145}
.c gettags [.c find closest {*}{90 125}]
} -cleanup {
.c delete all
} -result {rect}
test canvImg-8.8 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{101 136 110 145}
.c gettags [.c find closest {*}{90 125}]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.9 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{50 134 80 145}
.c gettags [.c find closest {*}{70 125}]
} -cleanup {
.c delete all
} -result {rect}
test canvImg-8.10 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{50 136 80 145}
.c gettags [.c find closest {*}{70 125}]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.11 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{20 134 31 145}
.c gettags [.c find closest {*}{40 125}]
} -cleanup {
.c delete all
} -result {rect}
test canvImg-8.12 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{20 136 29 145}
.c gettags [.c find closest {*}{40 125}]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.13 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{20 100 31 115}
.c gettags [.c find closest {*}{40 110}]
} -cleanup {
.c delete all
} -result {rect}
test canvImg-8.14 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{20 100 29 115}
.c gettags [.c find closest {*}{40 110}]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.15 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{20 70 31 80}
.c gettags [.c find closest {*}{40 90}]
} -cleanup {
.c delete all
} -result {rect}
test canvImg-8.16 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{20 70 29 79}
.c gettags [.c find closest {*}{40 90}]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.17 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{60 70 69 109}
.c gettags [.c find closest {*}{70 110}]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.18 {ImageToArea procedure} -constraints testImageType -setup {
.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 {}
} -body {
.c coords rect {*}{60 70 71 111}
.c gettags [.c find closest {*}{70 110}]
} -cleanup {
.c delete all
} -result {rect}
.c delete all
test canvImg-8.19 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 0 70 99]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.20 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 0 70 99.999]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.21 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 0 70 101]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.22 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 81 105 120 115]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.23 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 80.001 105 120 115]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.24 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 79 105 120 115]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.25 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 116 70 150]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.26 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 115.001 70 150]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.27 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 114 70 150]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.28 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 105 49 115]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.29 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 105 50 114.999]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.30 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 105 51 115]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.31 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 0 49.999 99.999]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.32 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 0 51 101]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.33 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 80 0 150 100]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.34 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 79 0 150 101]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.35 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 80.001 115.001 150 180]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.36 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 79 114 150 180]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.37 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 115 50 180]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.38 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 114 51 180]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.39 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 0 0 200 200]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.40 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 49.999 99.999 80.001 115.001]
} -cleanup {
.c delete all
} -result {image}
test canvImg-8.41 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 51 100 80 115]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.42 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 50 101 80 115]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.43 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 50 100 79 115]
} -cleanup {
.c delete all
} -result {}
test canvImg-8.44 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 50 100 80 114]
} -cleanup {
.c delete all
} -result {}
if {[testConstraint testImageType]} {
image delete foo
}
test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup {
.c delete all
image create test foo
} -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c scale image 25 0 2.0 1.5
.c bbox image
} -cleanup {
.c delete all
image delete foo
} -result {75 150 105 165}
test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup {
.c delete all
} -body {
image create test foo -variable x
.c create image 50 100 -image foo -tags image -anchor nw
update
set x {}
foo changed 2 4 6 8 30 15
update
return $x
} -cleanup {
.c delete all
image delete foo
} -result {{foo display 2 4 6 8 30 30}}
test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup {
.c delete all
} -body {
image create test foo -variable x
.c create image 50 100 -image foo -tags image -anchor nw
update
set x {}
foo changed 2 4 6 8 40 50
update
return $x
} -cleanup {
.c delete all
image delete foo
} -result {{foo display 0 0 40 50 30 30}}
test canvImg-11.2 {ImageChangedProc procedure} -constraints {
testImageType
} -setup {
.c delete all
} -body {
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
} -cleanup {
.c delete all
image delete foo
} -result {30 75 70 125}
test canvImg-11.3 {ImageChangedProc procedure} -constraints {
testImageType
} -setup {
.c delete all
} -body {
image create test foo -variable x
image create test foo2 -variable y
foo changed 0 0 0 0 40 50
foo2 changed 0 0 0 0 80 60
.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
return $y
} -cleanup {
.c delete all
image delete foo foo2
} -result {{foo2 display 0 0 20 40 50 40}}
# cleanup
imageFinish
cleanupTests
return
# Local variables:
# mode: tcl
# End:

56
tests/canvMoveto.test Normal file
View File

@@ -0,0 +1,56 @@
# This file is a Tcl script to test out the canvas "moveto" command. It is
# derived from canvRect.test.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2004 Neil McKay.
# All rights reserved.
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
canvas .c -width 400 -height 300 -bd 2 -relief sunken
.c create rectangle 20 20 80 80 -tag {test rect1}
.c create rectangle 40 40 90 100 -tag {test rect2}
test canvMoveto-1.1 {Bad args handling for "moveto" command} -body {
.c moveto test
} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
test canvMoveto-1.2 {Bad args handling for "moveto" command} -body {
.c moveto rect
} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
test canvMoveto-1.3 {Bad args handling for "moveto" command} -body {
.c moveto test 12
} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
test canvMoveto-1.4 {Bad args handling for "moveto" command} -body {
.c moveto test 12 y
} -returnCodes error -result {bad screen distance "y"}
test canvMoveto-1.5 {Bad args handling for "moveto" command} -body {
.c moveto test 12 20 -anchor
} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
test canvMoveto-2.1 {Canvas "moveto" command coordinates} {
.c moveto test 200 150
.c bbox test
} {200 150 272 232}
test canvMoveto-2.2 {Canvas "moveto" command, blank y coordinate} {
.c moveto test 200 150
.c moveto test 150 {}
.c bbox test
} {150 150 222 232}
test canvMoveto-2.3 {Canvas "moveto" command, blank x coordinate} {
.c moveto test 200 150
.c moveto test {} 200
.c bbox test
} {200 200 272 282}
.c delete withtag all
# cleanup
cleanupTests
return
# Local Variables:
# mode: tcl
# End:

196
tests/canvPs.test Normal file
View File

@@ -0,0 +1,196 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit
# canvas used in 1.* and 2.* test cases
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} -constraints {
unixOrPc
} -setup {
set foo [makeFile {} foo.ps]
} -body {
.c postscript -file $foo
file exists $foo
} -cleanup {
removeFile foo.ps
} -result 1
test canvPs-1.2 {test writing to a file, idempotency} -constraints {
unixOrPc
} -setup {
set foo [makeFile {} foo.ps]
set bar [makeFile {} bar.ps]
} -body {
.c postscript -file $foo
.c postscript -file $bar
set status ok
if {[file size $bar] != [file size $foo]} {
set status broken
}
set status
} -cleanup {
removeFile foo.ps
removeFile bar.ps
} -result ok
test canvPs-2.1 {test writing to a channel} -constraints {
unixOrPc
} -setup {
set foo [makeFile {} foo.ps]
file delete $foo
} -body {
set chan [open $foo w]
fconfigure $chan -translation lf
.c postscript -channel $chan
close $chan
file exists $foo
} -cleanup {
removeFile foo.ps
} -result 1
test canvPs-2.2 {test writing to channel, idempotency} -constraints {
unixOrPc
} -setup {
set foo [makeFile {} foo.ps]
set bar [makeFile {} bar.ps]
file delete $foo
file delete $bar
} -body {
set c1 [open $foo w]
set c2 [open $bar w]
fconfigure $c1 -translation lf
fconfigure $c2 -translation lf
.c postscript -channel $c1
.c postscript -channel $c2
close $c1
close $c2
set status ok
if {[file size $bar] != [file size $foo]} {
set status broken
}
set status
} -cleanup {
removeFile foo.ps
removeFile bar.ps
} -result ok
test canvPs-2.3 {test writing to channel and file, same output} -constraints {
unix
} -setup {
set foo [makeFile {} foo.ps]
set bar [makeFile {} bar.ps]
file delete $foo
file delete $bar
} -body {
set c1 [open $foo w]
fconfigure $c1 -translation lf
.c postscript -channel $c1
close $c1
.c postscript -file $bar
set status ok
if {[file size $foo] != [file size $bar]} {
set status broken
}
set status
} -cleanup {
removeFile foo.ps
removeFile bar.ps
} -result ok
test canvPs-2.4 {test writing to channel and file, same output} -constraints {
win
} -setup {
set foo [makeFile {} foo.ps]
set bar [makeFile {} bar.ps]
file delete $foo
file delete $bar
} -body {
set c1 [open $foo w]
fconfigure $c1 -translation crlf
.c postscript -channel $c1
close $c1
.c postscript -file $bar
set status ok
if {[file size $foo] != [file size $bar]} {
set status broken
}
set status
} -cleanup {
removeFile foo.ps
removeFile bar.ps
} -result ok
destroy .c
test canvPs-3.1 {test ps generation with an embedded window} -constraints {
notAqua
} -setup {
set bar [makeFile {} bar.ps]
file delete $bar
} -body {
pack [canvas .c -width 200 -height 200 -background white]
.c create rect 20 20 150 150 -tags rect0 -dash . -width 2
.c create arc 0 50 200 200 -tags arc0 \
-dash {4 4} -stipple question -outline red -fill green
image create photo logo \
-file [file join [file dirname [info script]] pwrdLogo150.gif]
.c create image 200 50 -image logo -anchor nw
entry .c.e -background pink -foreground blue -width 14
.c.e insert 0 "we gonna be postscripted"
.c create window 50 180 -anchor nw -window .c.e
update
.c postscript -file $bar
file exists $bar
} -cleanup {
destroy .c
imageCleanup
removeFile bar.ps
} -result {1}
test canvPs-3.2 {test ps generation with an embedded window not mapped} -setup {
set bar [makeFile {} bar.ps]
file delete $bar
} -body {
pack [canvas .c -width 200 -height 200 -background white]
entry .c.e -background pink -foreground blue -width 14
.c.e insert 0 "we gonna be postscripted"
.c create window 50 180 -anchor nw -window .c.e
.c postscript -file $bar
file exists $bar
} -cleanup {
destroy .c
removeFile bar.ps
} -result {1}
test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} -body {
pack [canvas .c]
.c create poly 10 20 10 20
.c postscript
} -cleanup {
destroy .c
} -returnCodes ok -match glob -result *
# cleanup
unset -nocomplain foo bar
imageFinish
deleteWindows
cleanupTests
return
# Local variables:
# mode: tcl
# End:

43
tests/canvPsArc.tcl Normal file
View File

@@ -0,0 +1,43 @@
# 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.
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

84
tests/canvPsBmap.tcl Normal file
View File

@@ -0,0 +1,84 @@
# 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.
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
set canvPsBmapImageDir [file join [file dirname [info script]] images]
$c create bitmap 0.5i 0.5i \
-bitmap @[file join $canvPsBmapImageDir flagdown.xbm] \
-background {} -foreground black -anchor nw
$c create rect 0.47i 0.47i 0.53i 0.53i -fill {} -outline black
$c create bitmap 3.0i 0.5i \
-bitmap @[file join $canvPsBmapImageDir flagdown.xbm] \
-background {} -foreground black -anchor n
$c create rect 2.97i 0.47i 3.03i 0.53i -fill {} -outline black
$c create bitmap 5.5i 0.5i \
-bitmap @[file join $canvPsBmapImageDir flagdown.xbm] \
-background black -foreground white -anchor ne
$c create rect 5.47i 0.47i 5.53i 0.53i -fill {} -outline black
$c create bitmap 0.5i 3.0i \
-bitmap @[file join $canvPsBmapImageDir face.xbm] \
-background {} -foreground black -anchor w
$c create rect 0.47i 2.97i 0.53i 3.03i -fill {} -outline black
$c create bitmap 3.0i 3.0i \
-bitmap @[file join $canvPsBmapImageDir face.xbm] \
-background {} -foreground black -anchor center
$c create rect 2.97i 2.97i 3.03i 3.03i -fill {} -outline black
$c create bitmap 5.5i 3.0i \
-bitmap @[file join $canvPsBmapImageDir face.xbm] \
-background blue -foreground black -anchor e
$c create rect 5.47i 2.97i 5.53i 3.03i -fill {} -outline black
$c create bitmap 0.5i 5.5i \
-bitmap @[file join $canvPsBmapImageDir flagup.xbm] \
-background black -foreground white -anchor sw
$c create rect 0.47i 5.47i 0.53i 5.53i -fill {} -outline black
$c create bitmap 3.0i 5.5i \
-bitmap @[file join $canvPsBmapImageDir flagup.xbm] \
-background green -foreground white -anchor s
$c create rect 2.97i 5.47i 3.03i 5.53i -fill {} -outline black
$c create bitmap 5.5i 5.5i \
-bitmap @[file join $canvPsBmapImageDir flagup.xbm] \
-background {} -foreground black -anchor se
$c create rect 5.47i 5.47i 5.53i 5.53i -fill {} -outline black

98
tests/canvPsGrph.tcl Normal file
View File

@@ -0,0 +1,98 @@
# 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.
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

84
tests/canvPsImg.tcl Normal file
View File

@@ -0,0 +1,84 @@
# This file creates a screen to exercise Postscript generation
# for images in canvases. It is part of the Tk visual test suite,
# which is invoked via the "visual" script.
# Build a test image in a canvas
proc BuildTestImage {} {
global BitmapImage PhotoImage visual level
catch {destroy .t.f}
frame .t.f -visual $visual -colormap new
pack .t.f -side top -after .t.top
bind .t.f <Enter> {wm colormapwindows .t {.t.f .t}}
bind .t.f <Leave> {wm colormapwindows .t {.t .t.f}}
canvas .t.f.c -width 550 -height 350 -borderwidth 2 -relief raised
pack .t.f.c
.t.f.c create rectangle 25 25 525 325 -fill {} -outline black
.t.f.c create image 50 50 -anchor nw -image $BitmapImage
.t.f.c create image 250 50 -anchor nw -image $PhotoImage
}
# Put postscript in a file
proc FilePostscript { canvas } {
global level
$canvas postscript -file /tmp/test.ps -colormode $level
}
# Send postscript output to printer
proc PrintPostcript { canvas } {
global level
$canvas postscript -file tmp.ps -colormode $level
exec lpr tmp.ps
}
catch {destroy .t}
toplevel .t
wm title .t "Postscript Tests for Canvases: Images"
wm iconname .t "Postscript"
message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for images. Click the buttons below to select a Visual type for the canvas and colormode for the Postscript output. Then click "Print" to send the results to the default printer, or "Print to file" to put the Postscript output in a file called "/tmp/test.ps". You can also click on items in the canvas to delete them.
NOTE: Some Postscript printers may not be able to handle Postscript generated in color mode.} -width 6i
pack .t.m -side top -fill both
frame .t.top
pack .t.top -side top
frame .t.top.l -relief raised -borderwidth 2
frame .t.top.r -relief raised -borderwidth 2
pack .t.top.l .t.top.r -side left -fill both -expand 1
label .t.visuals -text "Visuals"
pack .t.visuals -in .t.top.l
set visual [lindex [winfo visualsavailable .] 0]
foreach v [winfo visualsavailable .] {
# The hack below is necessary for some systems, which have more than one
# visual of the same type...
if {![winfo exists .t.$v]} {
radiobutton .t.$v -text $v -variable visual -value $v \
-command BuildTestImage
pack .t.$v -in .t.top.l -anchor w
}
}
label .t.levels -text "Color Levels"
pack .t.levels -in .t.top.r
set level monochrome
foreach l { monochrome gray color } {
radiobutton .t.$l -text $l -variable level -value $l
pack .t.$l -in .t.top.r -anchor w
}
set BitmapImage [image create bitmap \
-file [file join [file dirname [info script]] face.xbm] \
-background white -foreground black]
set PhotoImage [image create photo \
-file [file join [file dirname [info script]] teapot.ppm]]
BuildTestImage
frame .t.bot
pack .t.bot -side top -fill x -expand 1
button .t.file -text "Print to File" -command { FilePostscript .t.f.c }
button .t.print -text "Print" -command { PrintPostscript .t.f.c }
button .t.quit -text "Quit" -command { destroy .t }
pack .t.file .t.print .t.quit -in .t.bot -side left -fill x -expand 1

94
tests/canvPsText.tcl Normal file
View File

@@ -0,0 +1,94 @@
# 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.
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
}

475
tests/canvRect.test Normal file
View File

@@ -0,0 +1,475 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
# Canvas used in every test case of the whole file
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
update
# Rectangle used in canvRect-1.* tests
.c create rectangle 20 20 80 80 -tag test
test canvRect-1.1 {configuration options: good value for -fill} -body {
.c itemconfigure test -fill #ff0000
list [.c itemcget test -fill] [lindex [.c itemconfigure test -fill] 4]
} -result {{#ff0000} #ff0000}
test canvRect-1.2 {configuration options: bad value for -fill} -body {
.c itemconfigure test -fill non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test canvRect-1.3 {configuration options: good value for -outline} -body {
.c itemconfigure test -outline #123456
list [.c itemcget test -outline] [lindex [.c itemconfigure test -outline] 4]
} -result {{#123456} #123456}
test canvRect-1.4 {configuration options: bad value for -outline} -body {
.c itemconfigure test -outline non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test canvRect-1.5 {configuration options: good value for -stipple } -body {
.c itemconfigure test -stipple gray50
list [.c itemcget test -stipple ] [lindex [.c itemconfigure test -stipple ] 4]
} -result {gray50 gray50}
test canvRect-1.6 {configuration options: bad value for -stipple } -body {
.c itemconfigure test -stipple bogus
} -returnCodes error -result {bitmap "bogus" not defined}
test canvRect-1.7 {configuration options: good value for -tags} -body {
.c itemconfigure test -tags {test a b c}
list [.c itemcget test -tags] [lindex [.c itemconfigure test -tags] 4]
} -result {{test a b c} {test a b c}}
test canvRect-1.8 {configuration options} -body {
.c itemconfigure test -tags {test xyz}
.c itemcget xyz -tags
} -result {test xyz}
test canvRect-1.9 {configuration options: good value for -width} -body {
.c itemconfigure test -width 6.0
list [.c itemcget test -width] [lindex [.c itemconfigure test -width] 4]
} -result {6.0 6.0}
test canvRect-1.10 {configuration options: bad value for -width} -body {
.c itemconfigure test -width abc
} -returnCodes error -result {bad screen distance "abc"}
.c delete withtag all
test canvRect-2.1 {CreateRectOval procedure} -body {
.c create rect
} -returnCodes error -result {wrong # args: should be ".c create rect coords ?arg ...?"}
test canvRect-2.2 {CreateRectOval procedure} -body {
.c create oval x y z
} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 3}
test canvRect-2.3 {CreateRectOval procedure} -body {
.c create rectangle x 2 3 4
} -returnCodes error -result {bad screen distance "x"}
test canvRect-2.4 {CreateRectOval procedure} -body {
.c create rectangle 1 y 3 4
} -returnCodes error -result {bad screen distance "y"}
test canvRect-2.5 {CreateRectOval procedure} -body {
.c create rectangle 1 2 z 4
} -returnCodes error -result {bad screen distance "z"}
test canvRect-2.6 {CreateRectOval procedure} -body {
.c create rectangle 1 2 3 q
} -returnCodes error -result {bad screen distance "q"}
test canvRect-2.7 {CreateRectOval procedure} -body {
.c create rectangle 1 2 3 4 -tags x
set result {}
foreach element [.c coords x] {
lappend result [format %.1f $element]
}
set result
} -result {1.0 2.0 3.0 4.0}
test canvRect-2.8 {CreateRectOval procedure} -body {
.c create rectangle 1 2 3 4 -gorp foo
} -returnCodes error -result {unknown option "-gorp"}
.c delete withtag all
test canvRect-3.1 {RectOvalCoords procedure} -body {
.c create rectangle 10 20 30 40 -tags x
set result {}
foreach element [.c coords x] {
lappend result [format %.1f $element]
}
return $result
} -cleanup {
.c delete withtag all
} -result {10.0 20.0 30.0 40.0}
test canvRect-3.2 {RectOvalCoords procedure} -body {
.c create rectangle 10 20 30 40 -tags x
.c coords x a 2 3 4
} -cleanup {
.c delete withtag all
} -returnCodes error -result {bad screen distance "a"}
test canvRect-3.3 {RectOvalCoords procedure} -body {
.c create rectangle 10 20 30 40 -tags x
.c coords x 1 b 3 4
} -cleanup {
.c delete withtag all
} -returnCodes error -result {bad screen distance "b"}
test canvRect-3.4 {RectOvalCoords procedure} -body {
.c create rectangle 10 20 30 40 -tags x
.c coords x 1 2 c 4
} -cleanup {
.c delete withtag all
} -returnCodes error -result {bad screen distance "c"}
test canvRect-3.5 {RectOvalCoords procedure} -body {
.c create rectangle 10 20 30 40 -tags x
.c coords x 1 2 3 d
} -cleanup {
.c delete withtag all
} -returnCodes error -result {bad screen distance "d"}
test canvRect-3.6 {RectOvalCoords procedure} -constraints {
nonPortable
} -body {
.c create rectangle 10 20 30 40 -tags x
# Non-portable due to rounding differences.
.c coords x 10 25 15 40
.c bbox x
} -cleanup {
.c delete withtag all
} -result {9 24 16 41}
test canvRect-3.7 {RectOvalCoords procedure} -body {
.c create rectangle 10 20 30 40 -tags x
.c coords x 1 2 3 4 5
} -cleanup {
.c delete withtag all
} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 5}
test canvRect-4.1 {ConfigureRectOval procedure} -body {
.c create rectangle 10 20 30 40 -tags x -width 1
.c itemconfigure x -width abc
} -cleanup {
.c delete withtag all
} -returnCodes error -result {bad screen distance "abc"}
test canvRect-4.2 {ConfigureRectOval procedure} -body {
.c create rectangle 10 20 30 40 -tags x -width 1
catch {.c itemconfigure x -width abc}
.c itemcget x -width
} -cleanup {
.c delete withtag all
} -result {1.0}
test canvRect-4.3 {ConfigureRectOval procedure} -body {
.c create rectangle 10 20 30 40 -tags x -width 1
.c itemconfigure x -width -5
} -cleanup {
.c delete withtag all
} -returnCodes error -result {bad screen distance "-5"}
test canvRect-4.4 {ConfigureRectOval procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences
.c create rectangle 10 20 30 40 -tags x -width 1
.c itemconfigure x -width 10
.c bbox x
} -cleanup {
.c delete withtag all
} -result {5 15 35 45}
# I can't come up with any good tests for DeleteRectOval.
test canvRect-5.1 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
.c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 20 15 10 5
.c bbox x
} -cleanup {
.c delete withtag all
} -result {10 5 20 15}
test canvRect-5.2 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
.c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 10 20 30 10
.c itemconfigure x -width 1 -outline red
.c bbox x
} -cleanup {
.c delete withtag all
} -result {9 9 31 21}
test canvRect-5.3 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
.c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 10 20 30 10
.c itemconfigure x -width 2 -outline red
.c bbox x
} -cleanup {
.c delete withtag all
} -result {9 9 31 21}
test canvRect-5.4 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
.c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 10 20 30 10
.c itemconfigure x -width 3 -outline red
.c bbox x
} -cleanup {
.c delete withtag all
} -result {8 8 32 22}
# I can't come up with any good tests for DisplayRectOval.
test canvRect-6.1 {RectToPoint procedure} -body {
set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -outline {}
list [expr {[.c find closest 14.9 28] eq $xId}] \
[expr {[.c find closest 15.1 28] eq $yId}] \
[expr {[.c find closest 24.9 28] eq $yId}] \
[expr {[.c find closest 25.1 28] eq $xId}]
} -cleanup {
.c delete all
} -result {1 1 1 1}
test canvRect-6.2 {RectToPoint procedure} -body {
set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -outline {}
list [expr {[.c find closest 20 24.9] eq $xId}] \
[expr {[.c find closest 20 25.1] eq $yId}] \
[expr {[.c find closest 20 29.9] eq $yId}] \
[expr {[.c find closest 20 30.1] eq $xId}]
} -cleanup {
.c delete all
} -result {1 1 1 1}
test canvRect-6.3 {RectToPoint procedure} -body {
set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -width 1 -outline black
list [expr {[.c find closest 14.4 28] eq $xId}] \
[expr {[.c find closest 14.6 28] eq $yId}] \
[expr {[.c find closest 25.4 28] eq $yId}] \
[expr {[.c find closest 25.6 28] eq $xId}]
} -cleanup {
.c delete all
} -result {1 1 1 1}
test canvRect-6.4 {RectToPoint procedure} -body {
set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -width 1 -outline black
list [expr {[.c find closest 20 24.4] eq $xId}] \
[expr {[.c find closest 20 24.6] eq $yId}] \
[expr {[.c find closest 20 30.4] eq $yId}] \
[expr {[.c find closest 20 30.6] eq $xId}]
} -cleanup {
.c delete all
} -result {1 1 1 1}
test canvRect-6.5 {RectToPoint procedure} -body {
set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure x -fill {} -outline black -width 3
.c itemconfigure y -outline {}
list [expr {[.c find closest 13.2 28] eq $xId}] \
[expr {[.c find closest 13.3 28] eq $yId}] \
[expr {[.c find closest 26.7 28] eq $yId}] \
[expr {[.c find closest 26.8 28] eq $xId}]
} -cleanup {
.c delete all
} -result {1 1 1 1}
test canvRect-6.6 {RectToPoint procedure} -body {
set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure x -fill {} -outline black -width 3
.c itemconfigure y -outline {}
list [expr {[.c find closest 20 23.2] eq $xId}] \
[expr {[.c find closest 20 23.3] eq $yId}] \
[expr {[.c find closest 20 31.7] eq $yId}] \
[expr {[.c find closest 20 31.8] eq $xId}]
} -cleanup {
.c delete all
} -result {1 1 1 1}
test canvRect-6.7 {RectToPoint procedure} -body {
set xId [.c create rectangle 10 20 30 40 -outline {} -fill black]
set yId [.c create rectangle 40 40 50 50 -outline {} -fill black]
list [expr {[.c find closest 35 35] eq $xId}] \
[expr {[.c find closest 36 36] eq $yId}] \
[expr {[.c find closest 37 37] eq $yId}] \
[expr {[.c find closest 38 38] eq $yId}]
} -cleanup {
.c delete all
} -result {1 1 1 1}
test canvRect-7.1 {RectToArea procedure} -body {
set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
list [expr {[.c find overlapping 20 50 38 60] eq {}}] \
[expr {[.c find overlapping 20 50 39 60] eq $yId}] \
[expr {[.c find overlapping 20 50 70 60] eq $yId}] \
[expr {[.c find overlapping 61 50 70 60] eq $yId}] \
[expr {[.c find overlapping 62 50 70 60] eq {}}]
} -cleanup {
.c delete all
} -result {1 1 1 1 1}
test canvRect-7.2 {RectToArea procedure} -body {
set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
list [expr {[.c find overlapping 45 20 55 43] eq {}}] \
[expr {[.c find overlapping 45 20 55 44] eq $yId}] \
[expr {[.c find overlapping 45 20 55 80] eq $yId}] \
[expr {[.c find overlapping 45 71 55 80] eq $yId}] \
[expr {[.c find overlapping 45 72 55 80] eq {}}]
} -cleanup {
.c delete all
} -result {1 1 1 1 1}
test canvRect-7.3 {RectToArea procedure} -body {
set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
list [expr {[.c find overlapping 5 25 9.9 30] eq {}}] \
[expr {[.c find overlapping 5 25 10.1 30] eq $xId}]
} -cleanup {
.c delete all
} -result {1 1}
test canvRect-7.4 {RectToArea procedure} -body {
set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
list [expr {[.c find overlapping 102 152 118 168] eq {}}]\
[expr {[.c find overlapping 101 152 118 168] eq $zId}] \
[expr {[.c find overlapping 102 151 118 168] eq $zId}] \
[expr {[.c find overlapping 102 152 119 168] eq $zId}] \
[expr {[.c find overlapping 102 152 118 169] eq $zId}]
} -cleanup {
.c delete all
} -result {1 1 1 1 1}
test canvRect-7.5 {RectToArea procedure} -body {
set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
list [expr {[.c find enclosed 20 40 38 80] eq {}}] \
[expr {[.c find enclosed 20 40 39 80] eq {}}] \
[expr {[.c find enclosed 20 40 70 80] eq $yId}] \
[expr {[.c find enclosed 61 40 70 80] eq {}}] \
[expr {[.c find enclosed 62 40 70 80] eq {}}]
} -cleanup {
.c delete all
} -result {1 1 1 1 1}
test canvRect-7.6 {RectToArea procedure} -body {
set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
list [expr {[.c find enclosed 20 20 65 43] eq {}}] \
[expr {[.c find enclosed 20 20 65 44] eq {}}] \
[expr {[.c find enclosed 20 20 65 80] eq $yId}] \
[expr {[.c find enclosed 20 71 65 80] eq {}}] \
[expr {[.c find enclosed 20 72 65 80] eq {}}]
} -cleanup {
.c delete all
} -result {1 1 1 1 1}
test canvRect-8.1 {OvalToArea procedure} -body {
set xId [.c create oval 50 100 200 150 -fill green -outline {}]
set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
list [expr {[.c find overlapping 20 120 48 130] eq {}}] \
[expr {[.c find overlapping 20 120 49 130] eq "$yId $zId"}] \
[expr {[.c find overlapping 20 120 50.2 130] eq "$xId $yId $zId"}] \
[expr {[.c find overlapping 20 120 300 130] eq "$xId $yId $zId"}] \
[expr {[.c find overlapping 60 120 190 130] eq "$xId $yId"}] \
[expr {[.c find overlapping 199.9 120 300 130] eq "$xId $yId $zId"}] \
[expr {[.c find overlapping 201 120 300 130] eq "$yId $zId"}] \
[expr {[.c find overlapping 202 120 300 130] eq {}}]
} -cleanup {
.c delete all
} -result {1 1 1 1 1 1 1 1}
test canvRect-8.2 {OvalToArea procedure} -body {
set xId [.c create oval 50 100 200 150 -fill green -outline {}]
set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
list [expr {[.c find overlapping 100 50 150 98] eq {}}] \
[expr {[.c find overlapping 100 50 150 99] eq "$yId $zId"}] \
[expr {[.c find overlapping 100 50 150 100.1] eq "$xId $yId $zId"}] \
[expr {[.c find overlapping 100 50 150 200] eq "$xId $yId $zId"}] \
[expr {[.c find overlapping 100 110 150 140] eq "$xId $yId"}] \
[expr {[.c find overlapping 100 149.9 150 200] eq "$xId $yId $zId"}] \
[expr {[.c find overlapping 100 151 150 200] eq "$yId $zId"}] \
[expr {[.c find overlapping 100 152 150 200] eq {}}]
} -cleanup {
.c delete all
} -result {1 1 1 1 1 1 1 1}
test canvRect-8.3 {OvalToArea procedure} -body {
set xId [.c create oval 50 100 200 150 -fill green -outline {}]
set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
list [expr {[.c find overlapping 176 104 177 105] eq {}}] \
[expr {[.c find overlapping 187 116 188 117] eq "$xId $yId"}] \
[expr {[.c find overlapping 192 142 193 143] eq {}}] \
[expr {[.c find overlapping 180 138 181 139] eq "$xId $yId"}] \
[expr {[.c find overlapping 61 142 62 143] eq {}}] \
[expr {[.c find overlapping 65 137 66 136] eq "$xId $yId"}] \
[expr {[.c find overlapping 62 108 63 109] eq {}}] \
[expr {[.c find overlapping 68 115 69 116] eq "$xId $yId"}]
} -cleanup {
.c delete all
} -result {1 1 1 1 1 1 1 1}
test canvRect-9.1 {ScaleRectOval procedure} -setup {
.c delete withtag all
} -body {
.c create rect 100 300 200 350 -tags x
.c scale x 50 100 2 4
format {%.6g %.6g %.6g %.6g} {*}[.c coords x]
} -result {150 900 350 1100}
test canvRect-10.1 {TranslateRectOval procedure} -setup {
.c delete withtag all
} -body {
.c create rect 100 300 200 350 -tags x
.c move x 100 -10
format {%.6g %.6g %.6g %.6g} {*}[.c coords x]
} -result {200 290 300 340}
test canvRect-11.1 {RectOvalToPostscript procedure} -constraints {
nonPortable macCrash
} -setup {
.c delete withtag all
} -body {
# Crashes on Mac because the XGetImage() call isn't implemented, causing a
# dereference of NULL.
# This test is non-portable because different color information
# will get generated on different displays (e.g. mono displays
# vs. color).
.c configure -bd 0 -highlightthickness 0
.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
} -result {-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
}
# cleanup
cleanupTests
return

950
tests/canvText.test Normal file
View File

@@ -0,0 +1,950 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
# Canvas used in 1.* - 17.* tests
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
update
# Item used in 1.* tests
.c create text 20 20 -tag test
test canvText-1.1 {configuration options: good value for "anchor"} -body {
.c itemconfigure test -anchor nw
list [lindex [.c itemconfigure test -anchor] 4] [.c itemcget test -anchor]
} -result {nw nw}
test canvasText-1.2 {configuration options: bad value for "anchor"} -body {
.c itemconfigure test -anchor xyz
} -returnCodes error -result {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}
test canvText-1.3 {configuration options: good value for "fill"} -body {
.c itemconfigure test -fill #ff0000
list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill]
} -result {{#ff0000} #ff0000}
test canvasText-1.4 {configuration options: bad value for "fill"} -body {
.c itemconfigure test -fill xyz
} -returnCodes error -result {unknown color name "xyz"}
test canvText-1.5 {configuration options: good value for "fill"} -body {
.c itemconfigure test -fill {}
list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill]
} -result {{} {}}
test canvText-1.6 {configuration options: good value for "font"} -body {
.c itemconfigure test -font {Times 40}
list [lindex [.c itemconfigure test -font] 4] [.c itemcget test -font]
} -result {{Times 40} {Times 40}}
test canvasText-1.7 {configuration options: bad value for "font"} -body {
.c itemconfigure test -font {}
} -returnCodes error -result {font "" doesn't exist}
test canvText-1.8 {configuration options: good value for "justify"} -body {
.c itemconfigure test -justify left
list [lindex [.c itemconfigure test -justify] 4] [.c itemcget test -justify]
} -result {left left}
test canvasText-1.9 {configuration options: bad value for "justify"} -body {
.c itemconfigure test -justify xyz
} -returnCodes error -result {bad justification "xyz": must be left, right, or center}
test canvText-1.10 {configuration options: good value for "stipple"} -body {
.c itemconfigure test -stipple gray50
list [lindex [.c itemconfigure test -stipple] 4] [.c itemcget test -stipple]
} -result {gray50 gray50}
test canvasText-1.11 {configuration options: bad value for "stipple"} -body {
.c itemconfigure test -stipple xyz
} -returnCodes error -result {bitmap "xyz" not defined}
test canvText-1.12 {configuration options: good value for "underline"} -body {
.c itemconfigure test -underline 0
list [lindex [.c itemconfigure test -underline] 4] [.c itemcget test -underline]
} -result {0 0}
test canvasText-1.13 {configuration options: bad value for "underline"} -body {
.c itemconfigure test -underline xyz
} -returnCodes error -result {expected integer but got "xyz"}
test canvText-1.14 {configuration options: good value for "width"} -body {
.c itemconfigure test -width 6
list [lindex [.c itemconfigure test -width] 4] [.c itemcget test -width]
} -result {6 6}
test canvasText-1.15 {configuration options: bad value for "width"} -body {
.c itemconfigure test -width xyz
} -returnCodes error -result {bad screen distance "xyz"}
test canvText-1.16 {configuration options: good value for "tags"} -body {
.c itemconfigure test -tags {test a b c}
list [lindex [.c itemconfigure test -tags] 4] [.c itemcget test -tags]
} -result {{test a b c} {test a b c}}
test canvasText-1.17 {configuration options: bad value for "angle"} -body {
.c itemconfigure test -angle xyz
} -returnCodes error -result {expected floating-point number but got "xyz"}
test canvasText-1.18 {configuration options: good value for "angle"} -body {
.c itemconfigure test -angle 32.5
list [lindex [.c itemconfigure test -angle] 4] [.c itemcget test -angle]
} -result {32.5 32.5}
test canvasText-1.19 {configuration options: bounding of "angle"} -body {
.c itemconfigure test -angle 390
set result [.c itemcget test -angle]
.c itemconfigure test -angle -30
lappend result [.c itemcget test -angle]
.c itemconfigure test -angle -360
lappend result [.c itemcget test -angle]
} -result {30.0 330.0 0.0}
.c delete test
test canvText-2.1 {CreateText procedure: args} -body {
.c create text
} -returnCodes {error} -result {wrong # args: should be ".c create text coords ?arg ...?"}
test canvText-2.2 {CreateText procedure: args} -body {
.c create text xyz 0
} -cleanup {
.c delete all
} -returnCodes {error} -result {bad screen distance "xyz"}
test canvText-2.3 {CreateText procedure: args} -body {
.c create text 0 xyz
} -cleanup {
.c delete all
} -returnCodes {error} -result {bad screen distance "xyz"}
test canvText-2.4 {CreateText procedure: args} -body {
.c create text 0 0 -xyz xyz
} -cleanup {
.c delete all
} -returnCodes {error} -result {unknown option "-xyz"}
test canvText-2.5 {CreateText procedure} -body {
.c create text 0 0 -tags x
.c coords x
} -cleanup {
.c delete x
} -result {0.0 0.0}
test canvText-3.1 {TextCoords procedure} -body {
.c create text 20 20 -tag test
.c coords test 0 0
update
.c coords test
} -cleanup {
.c delete test
} -result {0.0 0.0}
test canvText-3.2 {TextCoords procedure} -setup {
.c create text 20 20 -tag test
} -body {
.c coords test xyz 0
} -cleanup {
.c delete test
} -returnCodes {error} -result {bad screen distance "xyz"}
test canvText-3.3 {TextCoords procedure} -setup {
.c create text 20 20 -tag test
} -body {
.c coords test 0 xyz
} -cleanup {
.c delete test
} -returnCodes {error} -result {bad screen distance "xyz"}
test canvText-3.4 {TextCoords procedure} -setup {
.c create text 20 20 -tag test
} -body {
.c coords test 10 10
set result {}
foreach element [.c coords test] {
lappend result [format %.1f $element]
}
return $result
} -cleanup {
.c delete test
} -result {10.0 10.0}
test canvText-3.5 {TextCoords procedure} -setup {
.c create text 20 20 -tag test
} -body {
.c coords test 10
} -cleanup {
.c delete test
} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
test canvText-3.6 {TextCoords procedure} -setup {
.c create text 20 20 -tag test
} -body {
.c coords test 10 10 10
} -cleanup {
.c delete test
} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3}
test canvText-4.1 {ConfigureText procedure} -setup {
.c create text 20 20 -tag test
} -body {
.c itemconfig test -fill xyz
} -cleanup {
.c delete test
} -returnCodes {error} -result {unknown color name "xyz"}
test canvText-4.2 {ConfigureText procedure} -setup {
.c create text 20 20 -tag test
} -body {
.c itemconfig test -fill blue
.c itemcget test -fill
} -cleanup {
.c delete test
} -result {blue}
test canvText-4.3 {ConfigureText procedure: construct font gcs} -setup {
.c create text 20 20 -tag test
} -body {
.c itemconfig test -font "times 20" -fill black -stipple gray50
list [.c itemcget test -font] [.c itemcget test -fill] [.c itemcget test -stipple]
} -cleanup {
.c delete test
} -result {{times 20} black gray50}
test canvText-4.4 {ConfigureText procedure: construct cursor gc} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.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
} -cleanup {
.c delete test
} -result {}
test canvText-4.5 {ConfigureText procedure: adjust selection} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
set x {}
} -body {
.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]
} -cleanup {
.c delete test
} -result {cdefg 1 cdefg cd cdef cd}
test canvText-4.6 {ConfigureText procedure: adjust cursor} -setup {
.c create text 20 20 -tag test
} -body {
.c itemconfig test -text "abcdefghi"
.c icursor test 6
.c dchars test 4 end
.c index test insert
} -cleanup {
.c delete test
} -result {4}
test canvText-5.1 {ConfigureText procedure: adjust cursor} -body {
.c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 \
-text "xyz"
.c delete x
} -result {}
test canvText-6.1 {ComputeTextBbox procedure} -constraints fonts -setup {
.c delete test
} -body {
set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
set ay [font metrics $font -linespace]
set ax [font measure $font 0]
.c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
expr {[.c itemconfig test -anchor n; .c bbox test] \
eq "[expr -$ax/2-1] 0 [expr $ax/2+1] $ay"}
} -cleanup {
.c delete test
} -result 1
test canvText-6.2 {ComputeTextBbox procedure} -constraints fonts -setup {
.c delete test
} -body {
set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
set ay [font metrics $font -linespace]
set ax [font measure $font 0]
.c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
expr {[.c itemconfig test -anchor nw; .c bbox test] \
eq "-1 0 [expr $ax+1] $ay"}
} -cleanup {
.c delete test
} -result 1
test canvText-6.3 {ComputeTextBbox procedure} -constraints fonts -setup {
.c delete test
} -body {
set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
set ay [font metrics $font -linespace]
set ax [font measure $font 0]
.c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
expr {[.c itemconfig test -anchor w; .c bbox test] \
eq "-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]"}
} -cleanup {
.c delete test
} -result 1
test canvText-6.4 {ComputeTextBbox procedure} -constraints fonts -setup {
.c delete test
} -body {
set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
set ay [font metrics $font -linespace]
set ax [font measure $font 0]
.c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
expr {[.c itemconfig test -anchor sw; .c bbox test] \
eq "-1 -$ay [expr $ax+1] 0"}
} -cleanup {
.c delete test
} -result 1
test canvText-6.5 {ComputeTextBbox procedure} -constraints fonts -setup {
.c delete test
} -body {
set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
set ay [font metrics $font -linespace]
set ax [font measure $font 0]
.c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
expr {[.c itemconfig test -anchor s; .c bbox test] \
eq "[expr -$ax/2-1] -$ay [expr $ax/2+1] 0"}
} -cleanup {
.c delete test
} -result 1
test canvText-6.6 {ComputeTextBbox procedure} -constraints fonts -setup {
.c delete test
} -body {
set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
set ay [font metrics $font -linespace]
set ax [font measure $font 0]
.c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
expr {[.c itemconfig test -anchor se; .c bbox test] \
eq "[expr -$ax-1] -$ay 1 0"}
} -cleanup {
.c delete test
} -result 1
test canvText-6.7 {ComputeTextBbox procedure} -constraints fonts -setup {
.c delete test
} -body {
set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
set ay [font metrics $font -linespace]
set ax [font measure $font 0]
.c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
expr {[.c itemconfig test -anchor e; .c bbox test]\
eq "[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]"}
} -cleanup {
.c delete test
} -result 1
test canvText-6.8 {ComputeTextBbox procedure} -constraints fonts -setup {
.c delete test
} -body {
set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
set ay [font metrics $font -linespace]
set ax [font measure $font 0]
.c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
expr {[.c itemconfig test -anchor ne; .c bbox test] \
eq "[expr -$ax-1] 0 1 $ay"}
} -cleanup {
.c delete test
} -result 1
test canvText-6.9 {ComputeTextBbox procedure} -constraints fonts -setup {
.c delete test
} -body {
set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
set ay [font metrics $font -linespace]
set ax [font measure $font 0]
.c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
expr {[.c itemconfig test -anchor center; .c bbox test] \
eq "[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]"}
} -cleanup {
.c delete test
} -result 1
#.c delete test
#.c create text 20 20 -tag test
#focus -force .c
#.c focus test
focus .c
.c focus test
.c itemconfig test -text "abcd\nefghi\njklmnopq"
test canvText-7.1 {DisplayText procedure: stippling} -body {
.c create text 20 20 -tag test
.c itemconfig test -stipple gray50
update
.c itemconfig test -stipple {}
update
} -cleanup {
.c delete test
} -result {}
test canvText-7.2 {DisplayText procedure: draw selection} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 0
.c select to test end
update
selection get
} -cleanup {
.c delete test
} -result "abcd\nefghi\njklmnopq"
test canvText-7.3 {DisplayText procedure: selection} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 0
.c select to test end
update
selection get
} -cleanup {
.c delete test
} -result "abcd\nefghi\njklmnopq"
test canvText-7.4 {DisplayText procedure: one line selection} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 2
.c select to test 3
update
} -cleanup {
.c delete test
} -result {}
test canvText-7.5 {DisplayText procedure: multi-line selection} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 2
.c select to test 12
update
} -cleanup {
.c delete test
} -result {}
test canvText-7.6 {DisplayText procedure: draw cursor} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcd\nefghi\njklmnopq"
.c icursor test 3
update
} -cleanup {
.c delete test
} -result {}
test canvText-7.7 {DisplayText procedure: selected text different color} -setup {
.c create text 20 20 -tag test
.c itemconfig test -text "abcd\nefghi\njklmnopq"
focus .c
.c focus test
} -body {
.c config -selectforeground blue
.c itemconfig test -anchor n
update
} -cleanup {
.c delete test
} -result {}
test canvText-7.8 {DisplayText procedure: not selected} -setup {
.c create text 20 20 -tag test
.c itemconfig test -text "abcd\nefghi\njklmnopq"
focus .c
.c focus test
} -body {
.c select clear
update
} -cleanup {
.c delete test
} -result {}
test canvText-7.9 {DisplayText procedure: select end} -setup {
destroy .t
} -body {
toplevel .t
wm geometry .t +0+0
canvas .t.c
pack .t.c
set id [.t.c create text 0 0 -text Dummy -anchor nw]
update
.t.c select from $id 0
.t.c select to $id end
update
#catch {destroy .t}
update
} -cleanup {
destroy .t
} -result {}
test canvText-8.1 {TextInsert procedure: 0 length insert} -setup {
.c create text 20 20 -tag test
.c itemconfig test -text "abcd\nefghi\njklmnopq"
focus .c
.c focus test
} -body {
.c insert test end {}
} -cleanup {
.c delete test
} -result {}
test canvText-8.2 {TextInsert procedure: before beginning/after end} -body {
# Can't test this because GetTextIndex filters out those numbers.
} -result {}
test canvText-8.3 {TextInsert procedure: inserting in a selected item} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c insert test 1 "xyz"
.c itemcget test -text
} -result {axyzbcdefg}
test canvText-8.4 {TextInsert procedure: inserting before selection} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.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]
} -result {5 7}
test canvText-8.5 {TextInsert procedure: inserting in selection} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.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]
} -result {2 7}
test canvText-8.6 {TextInsert procedure: inserting after selection} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.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]
} -result {2 4}
test canvText-8.7 {TextInsert procedure: inserting in unselected item} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcdefg"
.c select clear
.c insert test 5 "xyz"
.c itemcget test -text
} -result {abcdexyzfg}
test canvText-8.8 {TextInsert procedure: inserting before cursor} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcdefg"
.c icursor test 3
.c insert test 2 "xyz"
.c index test insert
} -result {6}
test canvText-8.9 {TextInsert procedure: inserting after cursor} -setup {
.c create text 20 20 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcdefg"
.c icursor test 3
.c insert test 4 "xyz"
.c index test insert
} -result {3}
# Item used in 9.* tests
.c create text 20 20 -tag test
test canvText-9.1 {TextInsert procedure: before beginning/after end} -body {
# Can't test this because GetTextIndex filters out those numbers.
} -result {}
test canvText-9.2 {TextInsert procedure: start > end} -body {
.c itemconfig test -text "abcdefg"
.c dchars test 4 2
.c itemcget test -text
} -result {abcdefg}
test canvText-9.3 {TextInsert procedure: deleting from a selected item} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c dchars test 3 5
.c itemcget test -text
} -result {abcg}
test canvText-9.4 {TextInsert procedure: deleting before start} -body {
.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]
} -result {3 7}
test canvText-9.5 {TextInsert procedure: keep start > first char deleted} -body {
.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]
} -result {2 3}
test canvText-9.6 {TextInsert procedure: deleting inside selection} -body {
.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]
} -result {4 7}
test canvText-9.7 {TextInsert procedure: keep end > first char deleted} -body {
.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]
} -result {4 5}
test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 3 10
.c index test sel.first
} -returnCodes {error} -result {selection isn't in item}
test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} -body {
.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]
} -result {4 4}
test canvText-9.10 {TextInsert procedure: move anchor} -body {
.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]
} -result {1 2}
test canvText-9.11 {TextInsert procedure: keep anchor >= first} -body {
.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]
} -result {1 4}
test canvText-9.12 {TextInsert procedure: anchor doesn't move} -body {
.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]
} -result {2 8}
test canvText-9.13 {TextInsert procedure: move cursor} -body {
.c itemconfig test -text "abcdefghijk"
.c icursor test 6
.c dchars test 2 4
.c index test insert
} -result {3}
test canvText-9.14 {TextInsert procedure: keep cursor >= first} -body {
.c itemconfig test -text "abcdefghijk"
.c icursor test 6
.c dchars test 2 10
.c index test insert
} -result {2}
test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body {
.c itemconfig test -text "abcdefghijk"
.c icursor test 5
.c dchars test 7 9
.c index test insert
} -result {5}
.c delete test
test canvText-10.1 {TextToPoint procedure} -body {
.c create text 0 0 -tag test
.c itemconfig test -text 0 -anchor center
.c index test @0,0
} -cleanup {
.c delete test
} -result {0}
test canvText-11.1 {TextToArea procedure} -setup {
.c create text 0 0 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text 0 -anchor center
set res1 [.c find overlapping 0 0 1 1]
set res2 [.c find withtag test]
expr {$res1 eq $res2}
} -cleanup {
.c delete test
} -result 1
test canvText-11.2 {TextToArea procedure} -setup {
.c create text 0 0 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text 0 -anchor center
.c find overlapping 1000 1000 1001 1001
} -cleanup {
.c delete test
} -result {}
test canvText-12.1 {ScaleText procedure} -body {
.c create text 100 100 -tag test
.c scale all 50 50 2 2
format {%.6g %.6g} {*}[.c coords test]
} -cleanup {
.c delete test
} -result {150 150}
test canvText-13.1 {TranslateText procedure} -body {
.c create text 100 100 -tag test
.c move all 10 10
format {%.6g %.6g} {*}[.c coords test]
} -cleanup {
.c delete test
} -result {110 110}
test canvText-14.1 {GetTextIndex procedure} -setup {
.c create text 0 0 -tag test
focus .c
.c focus test
} -body {
.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
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]
} -cleanup {
.c delete test
} -result {15 12 5 8 0 0 10 15}
test canvText-14.2 {GetTextIndex procedure: select error} -setup {
.c create text 0 0 -tag test
focus .c
.c focus test
} -body {
.c select clear
.c index test sel.first
} -cleanup {
.c delete test
} -returnCodes {error} -result {selection isn't in item}
test canvText-14.3 {GetTextIndex procedure: select error} -setup {
.c create text 0 0 -tag test
focus .c
.c focus test
} -body {
.c select clear
.c index test sel.last
} -cleanup {
.c delete test
} -returnCodes {error} -result {selection isn't in item}
test canvText-14.4 {GetTextIndex procedure: select error} -setup {
.c create text 0 0 -tag test
focus .c
.c focus test
} -body {
.c select clear
.c index test sel.
} -cleanup {
.c delete test
} -returnCodes {error} -result {bad index "sel."}
test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} -setup {
.c create text 0 0 -tag test
focus .c
.c focus test
} -body {
.c index test xyz
} -cleanup {
.c delete test
} -returnCodes {error} -result {bad index "xyz"}
test canvText-14.6 {select clear errors} -setup {
.c create text 0 0 -tag test
} -body {
.c select clear test
} -cleanup {
.c delete test
} -returnCodes error -result "wrong \# args: should be \".c select clear\""
test canvText-15.1 {SetTextCursor procedure} -setup {
.c create text 0 0 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcdefghijklmno" -anchor nw
.c itemconfig -text "abcdefg"
.c icursor test 3
.c index test insert
} -cleanup {
.c delete test
} -result {3}
test canvText-16.1 {GetSelText procedure} -setup {
.c create text 0 0 -tag test
focus .c
.c focus test
} -body {
.c itemconfig test -text "abcdefghijklmno" -anchor nw
.c select from test 5
.c select to test 8
selection get
} -cleanup {
.c delete test
} -result {fghi}
test canvText-17.1 {TextToPostscript procedure} -setup {
.c delete all
set result {findfont [font actual $font -size] scalefont ISOEncode setfont
0.000 0.000 0.000 setrgbcolor AdjustColor
0 100 200 \[
\[(000)\]
\[(000)\]
\[(00)\]
\] $ay -0.5 0 0 false DrawText
grestore
restore showpage
%%Trailer
end
%%EOF
}
} -body {
set font {Courier 12 italic}
set ax [font measure $font 0]
set ay [font metrics $font -linespace]
.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 "findfont " $x] end]
expr {$x eq [subst $result] ? "ok" : $x}
} -result ok
test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} -setup {
destroy .c
} -body {
pack [canvas .c]
.c create text 100 100 -text Hello\n -anchor nw
set bbox [.c bbox 1]
set x2 [lindex $bbox 2]
set y2 [lindex $bbox 3]
incr y2
update
.c find enclosed 99 99 [expr $x2 + 1] [expr $y2 + 1]
} -cleanup {
destroy .c
unset -nocomplain bbox x2 y2
} -result 1
test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} -setup {
destroy .c
set c [canvas .c -bg black -width 964]
pack $c
$c delete all
after 100 "set done 1"; vwait done
} -body {
set f {Arial 28 bold}
set s1 { Yeah-ah-ah-ah-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-Yow}
set s2 { Yeah ah ah ah oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh Yow}
$c create text 21 18 \
-font $f \
-text $s1 \
-fill white \
-width 922 \
-anchor nw \
-tags tbox1
$c create rect {*}[$c bbox tbox1] -outline red
$c create text 21 160 \
-font $f \
-text $s2 \
-fill white \
-width 922 \
-anchor nw \
-tags tbox2
$c create rect {*}[$c bbox tbox2] -outline red
after 500 "set done 1" ; vwait done
set results [list]
$c select from tbox2 4
$c select to tbox2 8
lappend results [selection get]
$c select from tbox1 4
$c select to tbox1 8
lappend results [selection get]
array set metrics [font metrics $f]
set x [expr {21 + [font measure $f " "] \
+ ([font measure {Arial 28 bold} "Y"] / 2)}]
set y1 [expr {18 + ($metrics(-linespace) / 2)}]
set y2 [expr {160 + ($metrics(-linespace) / 2)}]
lappend results [$c index tbox1 @$x,$y1]
lappend results [$c index tbox2 @$x,$y2]
} -cleanup {
destroy .c
} -result {{Yeah } Yeah- 4 4}
test canvText-20.1 {angled text bounding box} -setup {
destroy .c
canvas .c
proc transpose {bbox} {
lassign $bbox a b c d
list $b $a $d $c
}
} -body {
.c create text 2 2 -tag t -anchor center -text 0 -font {Helvetica 24}
set bb0 [.c bbox t]
.c itemconf t -angle 90
set bb1 [.c bbox t]
.c itemconf t -angle 180
set bb2 [.c bbox t]
.c itemconf t -angle 270
set bb3 [.c bbox t]
list [expr {$bb0 eq $bb2 ? "ok" : "$bb0,$bb2"}] \
[expr {$bb1 eq $bb3 ? "ok" : "$bb1,$bb3"}] \
[expr {$bb0 eq [transpose $bb1] ? "ok" : "$bb0,$bb1"}] \
} -cleanup {
destroy .c
rename transpose {}
} -result {ok ok ok}
# cleanup
cleanupTests
return

144
tests/canvWind.test Normal file
View File

@@ -0,0 +1,144 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} -setup {
destroy .t
} -body {
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]]
} -cleanup {
destroy .t
} -result {{1 23} {1 -29} {0 -29} {1 225} {0 225}}
test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} -setup {
destroy .t
} -body {
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]]
} -cleanup {
destroy .t
} -result {{1 3} {1 -49} {0 -49} {1 205} {0 205}}
test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} -setup {
destroy .t
} -body {
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]]
} -cleanup {
destroy .t
} -result {{1 23} {1 -59} {0 -59} {1 275} {0 275}}
test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} -setup {
destroy .t
} -body {
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]]
} -cleanup {
destroy .t
} -result {{1 3} {1 -79} {0 -79} {1 255} {0 255}}
# cleanup
cleanupTests
return

960
tests/canvas.test Normal file
View File

@@ -0,0 +1,960 @@
# 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.
# Copyright (c) 1998-2000 Ajuba Solutions.
# Copyright (c) 2008 Donal K. Fellows
# All rights reserved.
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit
# XXX - This test file is woefully incomplete. At present, only a few of the
# features are tested.
# Canvas used in 1.* test cases
canvas .c
pack .c
update
test canvas-1.1 {configuration options: good value for "background"} -body {
.c configure -background #ff0000
.c cget -background
} -result {#ff0000}
test canvas-1.2 {configuration options: bad value for "background"} -body {
.c configure -background non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test canvas-1.3 {configuration options: good value for "bg"} -body {
.c configure -bg #ff0000
.c cget -bg
} -result {#ff0000}
test canvas-1.4 {configuration options: bad value for "bg"} -body {
.c configure -bg non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test canvas-1.5 {configuration options: good value for "bd"} -body {
.c configure -bd 4
.c cget -bd
} -result {4}
test canvas-1.6 {configuration options: bad value for "bd"} -body {
.c configure -bd badValue
} -returnCodes error -result {bad screen distance "badValue"}
test canvas-1.7 {configuration options: good value for "borderwidth"} -body {
.c configure -borderwidth 1.3
.c cget -borderwidth
} -result {1}
test canvas-1.8 {configuration options: bad value for "borderwidth"} -body {
.c configure -borderwidth badValue
} -returnCodes error -result {bad screen distance "badValue"}
test canvas-1.9 {configuration options: good value for "closeenough"} -body {
.c configure -closeenough 24
.c cget -closeenough
} -result {24.0}
test canvas-1.10 {configuration options: bad value for "closeenough"} -body {
.c configure -closeenough bogus
} -returnCodes error -result {expected floating-point number but got "bogus"}
test canvas-1.11 {configuration options: good value for "confine"} -body {
.c configure -confine true
.c cget -confine
} -result {1}
test canvas-1.12 {configuration options: bad value for "confine"} -body {
.c configure -confine silly
} -returnCodes error -result {expected boolean value but got "silly"}
test canvas-1.13 {configuration options: good value for "cursor"} -body {
.c configure -cursor arrow
.c cget -cursor
} -result {arrow}
test canvas-1.14 {configuration options: bad value for "cursor"} -body {
.c configure -cursor badValue
} -returnCodes error -result {bad cursor spec "badValue"}
test canvas-1.15 {configuration options: good value for "height"} -body {
.c configure -height 2.1
.c cget -height
} -result {2}
test canvas-1.16 {configuration options: bad value for "height"} -body {
.c configure -height x42
} -returnCodes error -result {bad screen distance "x42"}
test canvas-1.17 {configuration options: good value for "highlightbackground"} -body {
.c configure -highlightbackground #112233
.c cget -highlightbackground
} -result {#112233}
test canvas-1.18 {configuration options: bad value for "highlightbackground"} -body {
.c configure -highlightbackground ugly
} -returnCodes error -result {unknown color name "ugly"}
test canvas-1.19 {configuration options: good value for "highlightcolor"} -body {
.c configure -highlightcolor #110022
.c cget -highlightcolor
} -result {#110022}
test canvas-1.20 {configuration options: bad value for "highlightcolor"} -body {
.c configure -highlightcolor bogus
} -returnCodes error -result {unknown color name "bogus"}
test canvas-1.21 {configuration options: good value for "highlightthickness"} -body {
.c configure -highlightthickness 18
.c cget -highlightthickness
} -result {18}
test canvas-1.22 {configuration options: bad value for "highlightthickness"} -body {
.c configure -highlightthickness badValue
} -returnCodes error -result {bad screen distance "badValue"}
test canvas-1.23 {configuration options: good value for "insertbackground"} -body {
.c configure -insertbackground #110022
.c cget -insertbackground
} -result {#110022}
test canvas-1.24 {configuration options: bad value for "insertbackground"} -body {
.c configure -insertbackground bogus
} -returnCodes error -result {unknown color name "bogus"}
test canvas-1.25 {configuration options: good value for "insertborderwidth"} -body {
.c configure -insertborderwidth 1.3
.c cget -insertborderwidth
} -result {1}
test canvas-1.26 {configuration options: bad value for "insertborderwidth"} -body {
.c configure -insertborderwidth 2.6x
} -returnCodes error -result {bad screen distance "2.6x"}
test canvas-1.27 {configuration options: good value for "insertofftime"} -body {
.c configure -insertofftime 100
.c cget -insertofftime
} -result {100}
test canvas-1.28 {configuration options: bad value for "insertofftime"} -body {
.c configure -insertofftime 3.2
} -returnCodes error -result {expected integer but got "3.2"}
test canvas-1.29 {configuration options: good value for "insertontime"} -body {
.c configure -insertontime 100
.c cget -insertontime
} -result {100}
test canvas-1.30 {configuration options: bad value for "insertontime"} -body {
.c configure -insertontime 3.2
} -returnCodes error -result {expected integer but got "3.2"}
test canvas-1.31 {configuration options: good value for "insertwidth"} -body {
.c configure -insertwidth 1.3
.c cget -insertwidth
} -result {1}
test canvas-1.32 {configuration options: bad value for "insertwidth"} -body {
.c configure -insertwidth 6x
} -returnCodes error -result {bad screen distance "6x"}
test canvas-1.33 {configuration options: good value for "relief"} -body {
.c configure -relief groove
.c cget -relief
} -result {groove}
test canvas-1.34 {configuration options: bad value for "relief"} -body {
.c configure -relief 1.5
} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
test canvas-1.35 {configuration options: good value for "selectbackground"} -body {
.c configure -selectbackground #110022
.c cget -selectbackground
} -result {#110022}
test canvas-1.36 {configuration options: bad value for "selectbackground"} -body {
.c configure -selectbackground bogus
} -returnCodes error -result {unknown color name "bogus"}
test canvas-1.37 {configuration options: good value for "selectborderwidth"} -body {
.c configure -selectborderwidth 1.3
.c cget -selectborderwidth
} -result {1}
test canvas-1.38 {configuration options: bad value for "selectborderwidth"} -body {
.c configure -selectborderwidth badValue
} -returnCodes error -result {bad screen distance "badValue"}
test canvas-1.39 {configuration options: good value for "selectforeground"} -body {
.c configure -selectforeground #654321
.c cget -selectforeground
} -result {#654321}
test canvas-1.40 {configuration options: bad value for "selectforeground"} -body {
.c configure -selectforeground bogus
} -returnCodes error -result {unknown color name "bogus"}
test canvas-1.41 {configuration options: good value for "takefocus"} -body {
.c configure -takefocus "any string"
.c cget -takefocus
} -result {any string}
test canvas-1.42 {configuration options: good value for "width"} -body {
.c configure -width 402
.c cget -width
} -result {402}
test canvas-1.43 {configuration options: bad value for "width"} -body {
.c configure -width xyz
} -returnCodes error -result {bad screen distance "xyz"}
test canvas-1.44 {configuration options: good value for "xscrollcommand"} -body {
.c configure -xscrollcommand {Some command}
.c cget -xscrollcommand
} -result {Some command}
test canvas-1.45 {configuration options: good value for "yscrollcommand"} -body {
.c configure -yscrollcommand {Another command}
.c cget -yscrollcommand
} -result {Another command}
test canvas-1.46 {configure throws error on bad option} -body {
.c configure -gorp foo
} -returnCodes error -match glob -result {*}
test canvas-1.47 {configure throws error on bad option} -body {
catch {.c configure -gorp foo}
.c create rect 10 10 100 100
.c configure -gorp foo
} -returnCodes error -match glob -result {*}
catch {destroy .c}
# Canvas used in 2.* test cases
canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
-highlightthickness 0
pack .c
update
test canvas-2.1 {CanvasWidgetCmd, bind option} -body {
set i [.c create rect 10 10 100 100]
.c bind $i <a>
} -cleanup {
.c delete $i
} -returnCodes ok
test canvas-2.2 {CanvasWidgetCmd, bind option} -body {
set i [.c create rect 10 10 100 100]
.c bind $i <
} -cleanup {
.c delete $i
} -returnCodes error -result {no event type or button # or keysym}
test canvas-2.3 {CanvasWidgetCmd, xview option} -body {
.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]
} -result {{0.0 0.3} {0.4 0.7}}
test canvas-2.4 {CanvasWidgetCmd, xview option} -constraints nonPortable -body {
# 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]
} -result {{0.6 0.9} {0.66 0.96}}
catch {destroy .c}
# Canvas used in 3.* test cases
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} -body {
.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]
} -result {{0.0 0.5} {0.1875 0.6875}}
test canvas-3.2 {CanvasWidgetCmd, yview option} -body {
.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]
} -result {{0.0 0.5} {0.1 0.6}}
destroy .c
test canvas-4.1 {ButtonEventProc procedure} -setup {
deleteWindows
set x {}
} -body {
canvas .c1 -bg #543210
rename .c1 .c2
lappend x [winfo children .]
lappend x [.c2 cget -bg]
destroy .c1
lappend x [info command .c*] [winfo children .]
} -result {.c1 #543210 {} {}}
test canvas-5.1 {ButtonCmdDeletedProc procedure} -body {
canvas .c1
rename .c1 {}
list [info command .c*] [winfo children .]
} -cleanup {
destroy .c1
} -result {{} {}}
# Canvas used in 6.* test cases
canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \
-borderwidth 2 -highlightthickness 3
pack .c
update
test canvas-6.1 {CanvasSetOrigin procedure} -body {
.c configure -xscrollincrement 0 -yscrollincrement 0
.c xview moveto 0
.c yview moveto 0
update
list [.c canvasx 0] [.c canvasy 0]
} -result {-205.0 -105.0}
test canvas-6.2 {CanvasSetOrigin procedure} -body {
.c configure -xscrollincrement 20 -yscrollincrement 10
set x ""
foreach i {.08 .10 .48 .50} {
.c xview moveto $i
update
lappend x [.c canvasx 0]
}
return $x
} -result {-165.0 -145.0 35.0 55.0}
test canvas-6.3 {CanvasSetOrigin procedure} -body {
.c configure -xscrollincrement 20 -yscrollincrement 10
set x ""
foreach i {.06 .08 .70 .72} {
.c yview moveto $i
update
lappend x [.c canvasy 0]
}
return $x
} -result {-95.0 -85.0 35.0 45.0}
test canvas-6.4 {CanvasSetOrigin procedure} -body {
.c configure -xscrollincrement 20 -yscrollincrement 10
.c xview moveto 1.0
.c canvasx 0
} -result {215.0}
test canvas-6.5 {CanvasSetOrigin procedure} -body {
.c configure -xscrollincrement 20 -yscrollincrement 10
.c yview moveto 1.0
.c canvasy 0
} -result {55.0}
deleteWindows
test canvas-7.1 {canvas widget vs hidden commands} -setup {
canvas .c
} -body {
interp hide {} .c
destroy .c
list [winfo children .] [lsort [interp hidden]]
} -cleanup {
destroy .c
} -result [list {} [lsort [interp hidden]]]
test canvas-8.1 {canvas arc bbox} -setup {
catch {destroy .c}
canvas .c
} -body {
.c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1
set arcBox [.c bbox arc1]
.c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2
set coordBox [.c bbox arc2]
.c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3
set pieBox [.c bbox arc3]
list $arcBox $coordBox $pieBox
} -result {{48 21 100 94} {248 21 300 94} {398 21 500 112}}
test canvas-9.1 {canvas id creation and deletion} -setup {
catch {destroy .c}
canvas .c
} -body {
# With Tk 8.0.4 the ids are now stored in a hash table. You can use this
# test as a performance test with older versions by changing the value of
# size.
set size 15
for {set i 0} {$i < $size} {incr i} {
set x [expr {-10 + 3*$i}]
for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} {
.c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \
-outline black -fill blue -tags rect
.c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \
-anchor center -tags text
}
}
# The actual bench mark - this code also exercises all the hash table
# changes.
set time [lindex [time {
foreach id [.c find withtag all] {
.c lower $id
.c raise $id
.c find withtag $id
.c bind <Return> $id {}
.c delete $id
}
}] 0]
set x ""
} -result {}
test canvas-10.1 {find items using tag expressions} -setup {
catch {destroy .c}
canvas .c
set res {}
} -body {
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 60 40 80 -fill yellow -tag [list b a]
.c create oval 20 100 40 120 -fill green -tag [list c b]
.c create oval 20 140 40 160 -fill blue -tag [list b]
.c create oval 20 180 40 200 -fill bisque -tag [list a d e]
.c create oval 20 220 40 240 -fill bisque -tag b
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
lappend res [.c find withtag {!a}]
lappend res [.c find withtag {b&&c}]
lappend res [.c find withtag {b||c}]
lappend res [.c find withtag {a&&!b}]
lappend res [.c find withtag {!b&&!c}]
lappend res [.c find withtag {d&&a&&c&&b}]
lappend res [.c find withtag {b^a}]
lappend res [.c find withtag {(a&&!b)||(!a&&b)}]
lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }]
lappend res [.c find withtag {a&&!(c||d)}]
lappend res [.c find withtag {d&&"tag with spaces"}]
lappend res [.c find withtag "tag with spaces"]
} -result {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7}
test canvas-10.2 {check errors from tag expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
.c find withtag {&&c}
} -returnCodes error -result {unexpected operator in tag search expression}
test canvas-10.3 {check errors from tag expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
.c find withtag {!!c}
} -returnCodes error -result {too many '!' in tag search expression}
test canvas-10.4 {check errors from tag expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
.c find withtag {b||}
} -returnCodes error -result {missing tag in tag search expression}
test canvas-10.5 {check errors from tag expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
.c find withtag {b&&(c||)}
} -returnCodes error -result {unexpected operator in tag search expression}
test canvas-10.6 {check errors from tag expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
.c find withtag {d&&""}
} -returnCodes error -result {null quoted tag string in tag search expression}
test canvas-10.7 {check errors from tag expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
.c find withtag "d&&\"tag with spaces"
} -returnCodes error -result {missing endquote in tag search expression}
test canvas-10.8 {check errors from tag expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -returnCodes error -body {
.c find withtag {a&&"tag with spaces"z}
} -result {invalid boolean operator in tag search expression}
test canvas-10.9 {check errors from tag expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
.c find withtag {a&&b&c}
} -returnCodes error -result {singleton '&' in tag search expression}
test canvas-10.10 {check errors from tag expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red -tag [list a b c d]
.c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
.c find withtag {a||b|c}
} -returnCodes error -result {singleton '|' in tag search expression}
test canvas-10.11 {backward compatility - strange tags that are not expressions} -setup {
catch {destroy .c}
canvas .c
.c create oval 20 20 40 40 -fill red \
-tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }]
} -body {
.c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }
} -result 1
test canvas-10.12 {multple events bound to same tag expr} -setup {
catch {destroy .c}
canvas .c
} -body {
.c bind {a && b} <Enter> {puts Enter}
.c bind {a && b} <Leave> {puts Leave}
} -result {}
test canvas-10.13 {more long tag searches; Bug 2931374} -setup {
catch {destroy .c}
canvas .c
} -body {
.c find withtag {(A&&B&&C&&D)&&area&&!text}
# memory errors on failure
} -cleanup {
destroy .c
} -result {}
test canvas-11.1 {canvas poly fill check, bug 5783} -setup {
destroy .c
pack [canvas .c]
} -body {
# This would crash in 8.3.0 and 8.3.1
.c create polygon 0 0 100 100 200 50 \
-fill {} -stipple gray50 -outline black
} -result 1
test canvas-11.2 {canvas poly overlap fill check, bug 226357} -setup {
destroy .c
pack [canvas .c]
set result {}
} -body {
.c create poly 30 30 90 90 30 90 90 30
lappend result [.c find over 40 40 45 45]; # rect region inc. edge
lappend result [.c find over 60 40 60 40]; # top-center point
lappend result [.c find over 0 0 0 0]; # not on poly
lappend result [.c find over 60 60 60 60]; # center-point
lappend result [.c find over 45 50 45 50]; # outside poly
.c itemconfig 1 -fill "" -outline black
lappend result [.c find over 40 40 45 45]; # rect region inc. edge
lappend result [.c find over 60 40 60 40]; # top-center point
lappend result [.c find over 0 0 0 0]; # not on poly
lappend result [.c find over 60 60 60 60]; # center-point
lappend result [.c find over 45 50 45 50]; # outside poly
.c itemconfig 1 -width 8
lappend result [.c find over 45 50 45 50]; # outside poly
} -result {1 1 {} 1 {} 1 1 {} 1 {} 1}
test canvas-11.3 {canvas poly dchars, bug 3291543} {
# This would crash
destroy .c
pack [canvas .c]
.c create polygon 0 0 0 10 10 0
.c dchars 1 2 end
.c coords 1
} {}
test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} -setup {
destroy .c
pack [canvas .c]
} -body {
set qx [expr {1.+1.}]
# qx has type double and no string representation
.c scale all $qx 0 1. 1.
# qx has now type MMRep and no string representation
list $qx [string length $qx]
} -result {2.0 3}
test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup {
destroy .c
pack [canvas .c]
} -body {
set val 10
incr val
# qx has type double and no string representation
.c scale all $val 0 1 1
# qx has now type MMRep and no string representation
incr val
} -result 12
# procedure used in 13.1 test case
proc kill_canvas {w} {
destroy $w
pack [canvas $w -height 200 -width 200] -fill both -expand yes
update idle
$w create rectangle 80 80 120 120 -fill blue -tags blue
# bind a button press to re-build the canvas
$w bind blue <ButtonRelease-1> [subst {
[lindex [info level 0] 0] $w
append ::x ok
}]
}
test canvas-13.1 {canvas delete during event, SF bug-228024} -body {
kill_canvas .c
set ::x {}
# do this many times to improve chances of triggering the crash
for {set i 0} {$i < 30} {incr i} {
event generate .c <1> -x 100 -y 100
event generate .c <ButtonRelease-1> -x 100 -y 100
}
return $::x
} -result {okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok}
test canvas-14.1 {canvas scan SF bug 581560} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c scan
} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
test canvas-14.2 {canvas scan} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c scan bogus
} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
test canvas-14.3 {canvas scan} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c scan mark
} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
test canvas-14.4 {canvas scan} -setup {
destroy .c
canvas .c
} -body {
.c scan mark 10 10
} -result {}
test canvas-14.5 {canvas scan} -setup {
destroy .c
canvas .c
} -body {
.c scan mark 10 10 5
} -returnCodes error -result {wrong # args: should be ".c scan mark x y"}
test canvas-14.6 {canvas scan} -setup {
destroy .c
canvas .c
} -body {
.c scan dragto 10 10 5
} -result {}
test canvas-15.1 {basic types check: arc requires coords} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create arc
} -result {wrong # args: should be ".c create arc coords ?arg ...?"}
test canvas-15.2 "basic coords check: arc coords are paired" -setup {
destroy .c
canvas .c
} -body {
.c create arc 0
} -returnCodes error -result {wrong # coordinates: expected 4, got 1}
test canvas-15.3 {basic types check: bitmap requires coords} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create bitmap
} -result {wrong # args: should be ".c create bitmap coords ?arg ...?"}
test canvas-15.4 "basic coords check: bitmap coords are paired" -setup {
destroy .c
canvas .c
} -body {
.c create bitmap 0
} -returnCodes error -result {wrong # coordinates: expected 2, got 1}
test canvas-15.5 {basic types check: image requires coords} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create image
} -result {wrong # args: should be ".c create image coords ?arg ...?"}
test canvas-15.6 "basic coords check: image coords are paired" -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create image 0
} -result {wrong # coordinates: expected 2, got 1}
test canvas-15.7 {basic types check: line requires coords} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create line
} -result {wrong # args: should be ".c create line coords ?arg ...?"}
test canvas-15.8 "basic coords check: line coords are paired" -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create line 0
} -result {wrong # coordinates: expected an even number, got 1}
test canvas-15.9 {basic types check: oval requires coords} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create oval
} -result {wrong # args: should be ".c create oval coords ?arg ...?"}
test canvas-15.10 "basic coords check: oval coords are paired" -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create oval 0
} -result {wrong # coordinates: expected 0 or 4, got 1}
test canvas-15.11 {basic types check: polygon requires coords} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create polygon
} -result {wrong # args: should be ".c create polygon coords ?arg ...?"}
test canvas-15.12 "basic coords check: polygon coords are paired" -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create polygon 0
} -result {wrong # coordinates: expected an even number, got 1}
test canvas-15.13 {basic types check: rect requires coords} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create rect
} -result {wrong # args: should be ".c create rect coords ?arg ...?"}
test canvas-15.14 "basic coords check: rect coords are paired" -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create rect 0
} -result {wrong # coordinates: expected 0 or 4, got 1}
test canvas-15.15 {basic types check: text requires coords} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create text
} -result {wrong # args: should be ".c create text coords ?arg ...?"}
test canvas-15.16 "basic coords check: text coords are paired" -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create text 0
} -result {wrong # coordinates: expected 2, got 1}
test canvas-15.17 {basic types check: window requires coords} -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create window
} -result {wrong # args: should be ".c create window coords ?arg ...?"}
test canvas-15.18 "basic coords check: window coords are paired" -setup {
destroy .c
canvas .c
} -returnCodes error -body {
.c create window 0
} -result {wrong # coordinates: expected 2, got 1}
test canvas-15.19 "basic coords check: centimeters are larger than pixels" -setup {
destroy .c
canvas .c
} -body {
set id [.c create rect 0 0 1cm 1cm]
expr {[lindex [.c coords $id] 2]>1}
} -result {1}
destroy .c
test canvas-16.1 {arc coords check} -setup {
canvas .c
} -body {
set id [.c create arc {0 10 20 30} -start 33]
.c itemcget $id -start
} -cleanup {
destroy .c
} -result {33.0}
test canvas-17.1 {default smooth method handling} -setup {
canvas .c
} -body {
set id [.c create line {0 0 1 1 2 2 3 3 4 4 5 5 6 6}]
set result [.c itemcget $id -smooth]
foreach smoother {yes 1 bezier raw r b} {
.c itemconfigure $id -smooth $smoother
lappend result [.c itemcget $id -smooth]
}
return $result
} -cleanup {
destroy .c
} -result {0 true true true raw raw true}
test canvas-18.1 {imove method - lines} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1 2 2 3 3]
.c imove $id 0 4 4
.c coords $id
} -cleanup {
destroy .c
} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0}
test canvas-18.2 {imove method - lines} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1]
.c imove $id 0 4 4
.c coords $id
} -cleanup {
destroy .c
} -result {4.0 4.0 1.0 1.0}
test canvas-18.3 {imove method - lines} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1 2 2 3 3]
.c imove $id @1,1 4 4
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0}
test canvas-18.4 {imove method - lines} -constraints knownBug -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1 2 2 3 3]
.c imove $id end 4 4
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0}
test canvas-18.5 {imove method - polygon} -setup {
canvas .c
} -body {
set id [.c create polygon 0 0 1 1 2 2 3 3]
.c imove $id 0 4 4
.c coords $id
} -cleanup {
destroy .c
} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0}
test canvas-18.6 {imove method - polygon} -setup {
canvas .c
} -body {
set id [.c create polygon 0 0 1 1]
.c imove $id 0 4 4
.c coords $id
} -cleanup {
destroy .c
} -result {4.0 4.0 1.0 1.0}
test canvas-18.7 {imove method - polygon} -setup {
canvas .c
} -body {
set id [.c create polygon 0 0 1 1 2 2 3 3]
.c imove $id @1,1 4 4
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0}
test canvas-18.8 {imove method - polygon} -constraints knownBug -setup {
canvas .c
} -body {
set id [.c create polygon 0 0 1 1 2 2 3 3]
.c imove $id end 4 4
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0}
test canvas-18.9 {imove method - errors} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1 2 2 3 3]
.c imove $id foobar 4 4
} -cleanup {
destroy .c
} -returnCodes error -result {bad index "foobar"}
test canvas-18.10 {imove method - errors} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1 2 2 3 3]
.c imove $id 0 foobar 4
} -cleanup {
destroy .c
} -returnCodes error -result {bad screen distance "foobar"}
test canvas-18.11 {imove method - errors} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1 2 2 3 3]
.c imove $id 0 4 foobar
} -cleanup {
destroy .c
} -returnCodes error -result {bad screen distance "foobar"}
test canvas-19.1 {rchars method - lines} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1 2 2 3 3]
.c rchars $id 2 4 {4 4}
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 4.0 4.0 3.0 3.0}
test canvas-19.2 {rchars method - lines} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1 2 2 3 3]
.c rchars $id 2 4 {}
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 3.0 3.0}
test canvas-19.3 {rchars method - lines} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1 2 2 3 3]
.c rchars $id 2 4 {10 11 12 13 14 15}
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0}
test canvas-19.4 {rchars method - polygon} -setup {
canvas .c
} -body {
set id [.c create polygon 0 0 1 1 2 2 3 3]
.c rchars $id 2 4 {4 4}
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 4.0 4.0 3.0 3.0}
test canvas-19.5 {rchars method - polygon} -setup {
canvas .c
} -body {
set id [.c create polygon 0 0 1 1 2 2 3 3]
.c rchars $id 2 4 {}
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 3.0 3.0}
test canvas-19.6 {rchars method - polygon} -setup {
canvas .c
} -body {
set id [.c create polygon 0 0 1 1 2 2 3 3]
.c rchars $id 2 4 {10 11 12 13 14 15}
.c coords $id
} -cleanup {
destroy .c
} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0}
test canvas-19.7 {rchars method - text} -setup {
canvas .c
} -body {
set id [.c create text 0 0 -text abcde]
.c rchars $id 1 3 XYZ
.c itemcget $id -text
} -cleanup {
destroy .c
} -result aXYZe
test canvas-19.8 {rchars method - text} -setup {
canvas .c
} -body {
set id [.c create text 0 0 -text abcde]
.c rchars $id 1 3 {}
.c itemcget $id -text
} -cleanup {
destroy .c
} -result ae
test canvas-19.9 {rchars method - text} -setup {
canvas .c
} -body {
set id [.c create text 0 0 -text abcde]
.c rchars $id 1 3 FOOBAR
.c itemcget $id -text
} -cleanup {
destroy .c
} -result aFOOBARe
test canvas-19.10 {rchars method - errors} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1]
.c rchars $id foo 1 {2 2}
} -cleanup {
destroy .c
} -returnCodes error -result {bad index "foo"}
test canvas-19.11 {rchars method - errors} -setup {
canvas .c
} -body {
set id [.c create line 0 0 1 1]
.c rchars $id 1 foo {2 2}
} -cleanup {
destroy .c
} -returnCodes error -result {bad index "foo"}
# cleanup
imageCleanup
cleanupTests
return
# Local Variables:
# mode: tcl
# End:

172
tests/choosedir.test Normal file
View File

@@ -0,0 +1,172 @@
# This file is a Tcl script to test out Tk's "tk_chooseDir" and
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
#----------------------------------------------------------------------
#
# Procedures needed by this test file
#
#----------------------------------------------------------------------
proc ToPressButton {parent btn} {
after 100 SendButtonPress $parent $btn mouse
}
proc ToEnterDirsByKey {parent dirs} {
after 100 [list EnterDirsByKey $parent $dirs]
}
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 EnterDirsByKey {parent dirs} {
global tk_strictMotif
if {$parent == "."} {
set w .__tk_choosedir
} else {
set w $parent.__tk_choosedir
}
upvar ::tk::dialog::file::__tk_choosedir data
foreach dir $dirs {
$data(ent) delete 0 end
$data(ent) insert 0 $dir
update
SendButtonPress $parent ok mouse
after 50
}
}
proc SendButtonPress {parent btn type} {
global tk_strictMotif
if {$parent == "."} {
set w .__tk_choosedir
} else {
set w $parent.__tk_choosedir
}
upvar ::tk::dialog::file::__tk_choosedir 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
#
#----------------------------------------------------------------------
# Make a dir for us to rely on for tests
set real [makeDirectory choosedirTest]
set dir [file dirname $real]
set fake [file join $dir non-existant]
set parent .
test choosedir-1.1 {tk_chooseDirectory command} -constraints unix -body {
tk_chooseDirectory -initialdir
} -returnCodes error -result {value for "-initialdir" missing}
test choosedir-1.2 {tk_chooseDirectory command} -constraints unix -body {
tk_chooseDirectory -mustexist
} -returnCodes error -result {value for "-mustexist" missing}
test choosedir-1.3 {tk_chooseDirectory command} -constraints unix -body {
tk_chooseDirectory -parent
} -returnCodes error -result {value for "-parent" missing}
test choosedir-1.4 {tk_chooseDirectory command} -constraints unix -body {
tk_chooseDirectory -title
} -returnCodes error -result {value for "-title" missing}
test choosedir-1.5 {tk_chooseDirectory command} -constraints unix -body {
tk_chooseDirectory -foo bar
} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
test choosedir-1.6 {tk_chooseDirectory command} -constraints unix -body {
tk_chooseDirectory -parent foo.bar
} -returnCodes error -result {bad window path name "foo.bar"}
test choosedir-2.1 {tk_chooseDirectory command, cancel gives null} -constraints {
unix notAqua
} -body {
ToPressButton $parent cancel
tk_chooseDirectory -title "Press Cancel" -parent $parent
} -result {}
test choosedir-3.1 {tk_chooseDirectory -mustexist 1} -constraints {
unix notAqua
} -body {
# first enter a bogus dirname, then enter a real one.
ToEnterDirsByKey $parent [list $fake $real $real]
set result [tk_chooseDirectory \
-title "Enter \"$fake\", press OK, enter \"$real\", press OK" \
-parent $parent -mustexist 1]
set result
} -result $real
test choosedir-3.2 {tk_chooseDirectory -mustexist 0} -constraints {
unix notAqua
} -body {
ToEnterDirsByKey $parent [list $fake $fake]
tk_chooseDirectory -title "Enter \"$fake\", press OK" \
-parent $parent -mustexist 0
} -result $fake
test choosedir-4.1 {tk_chooseDirectory command, initialdir} -constraints {
unix notAqua
} -body {
ToPressButton $parent ok
tk_chooseDirectory -title "Press Ok" -parent $parent -initialdir $real
} -result $real
test choosedir-4.2 {tk_chooseDirectory command, initialdir} -constraints {
unix notAqua
} -body {
ToEnterDirsByKey $parent [list $fake $fake]
tk_chooseDirectory \
-title "Enter \"$fake\" and press Ok" \
-parent $parent -initialdir $real
} -result $fake
test choosedir-4.3 {tk_chooseDirectory command, {} initialdir} -constraints {
unix notAqua
} -body {
catch {unset ::tk::dialog::file::__tk_choosedir}
ToPressButton $parent ok
tk_chooseDirectory \
-title "Press OK" \
-parent $parent -initialdir ""
} -result [pwd]
test choosedir-5.1 {tk_chooseDirectory, handles {} entry text} -constraints {
unix notAqua
} -body {
ToEnterDirsByKey $parent [list "" $real $real]
tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \
-parent $parent
} -result $real
# cleanup
removeDirectory choosedirTest
cleanupTests
return

361
tests/clipboard.test Normal file
View File

@@ -0,0 +1,361 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# Note: Multiple display clipboard handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
# 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} -setup {
clipboard clear
} -body {
clipboard append "test"
clipboard get
} -cleanup {
clipboard clear
} -result {test}
test clipboard-1.2 {ClipboardHandler procedure} -setup {
clipboard clear
} -body {
clipboard append "test"
clipboard append "ing"
clipboard get
} -cleanup {
clipboard clear
} -result {testing}
test clipboard-1.3 {ClipboardHandler procedure} -setup {
clipboard clear
} -body {
clipboard append "t"
clipboard append "e"
clipboard append "s"
clipboard append "t"
clipboard get
} -cleanup {
clipboard clear
} -result {test}
test clipboard-1.4 {ClipboardHandler procedure} -setup {
clipboard clear
} -body {
clipboard append $longValue
clipboard get
} -cleanup {
clipboard clear
} -result "$longValue"
test clipboard-1.5 {ClipboardHandler procedure} -setup {
clipboard clear
} -body {
clipboard append $longValue
clipboard append "test"
clipboard get
} -cleanup {
clipboard clear
} -result "${longValue}test"
test clipboard-1.6 {ClipboardHandler procedure} -setup {
clipboard clear
} -body {
clipboard append -t TEST $longValue
clipboard append -t STRING "test"
list [clipboard get -t STRING] [clipboard get -t TEST]
} -cleanup {
clipboard clear
} -result [list test $longValue]
test clipboard-1.7 {ClipboardHandler procedure} -setup {
clipboard clear
} -body {
clipboard append -t TEST [string range $longValue 1 4000]
clipboard append -t STRING "test"
list [clipboard get -t STRING] [clipboard get -t TEST]
} -cleanup {
clipboard clear
} -result [list test [string range $longValue 1 4000]]
test clipboard-1.8 {ClipboardHandler procedure} -setup {
clipboard clear
} -body {
clipboard append ""
clipboard get
} -cleanup {
clipboard clear
} -result {}
test clipboard-1.9 {ClipboardHandler procedure} -setup {
clipboard clear
} -body {
clipboard append ""
clipboard append "Test"
clipboard get
} -cleanup {
clipboard clear
} -result {Test}
##############################################################################
test clipboard-2.1 {ClipboardAppHandler procedure} -setup {
set oldAppName [tk appname]
clipboard clear
} -body {
tk appname UnexpectedName
clipboard append -type NEW_TYPE Data
selection get -selection CLIPBOARD -type TK_APPLICATION
} -cleanup {
tk appname $oldAppName
clipboard clear
} -result {UnexpectedName}
##############################################################################
test clipboard-3.1 {ClipboardWindowHandler procedure} -setup {
set oldAppName [tk appname]
clipboard clear
} -body {
tk appname UnexpectedName
clipboard append -type NEW_TYPE Data
selection get -selection CLIPBOARD -type TK_WINDOW
} -cleanup {
tk appname $oldAppName
clipboard clear
} -result {.}
##############################################################################
test clipboard-4.1 {ClipboardLostSel procedure} -setup {
clipboard clear
} -body {
clipboard append "Test"
selection clear -s CLIPBOARD
clipboard get
} -cleanup {
clipboard clear
} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
test clipboard-4.2 {ClipboardLostSel procedure} -setup {
clipboard clear
} -body {
clipboard append "Test"
clipboard append -t TEST "Test2"
selection clear -s CLIPBOARD
clipboard get
} -cleanup {
clipboard clear
} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
test clipboard-4.3 {ClipboardLostSel procedure} -setup {
clipboard clear
} -body {
clipboard append "Test"
clipboard append -t TEST "Test2"
selection clear -s CLIPBOARD
catch {clipboard get}
clipboard get -t TEST
} -cleanup {
clipboard clear
} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined}
test clipboard-4.4 {ClipboardLostSel procedure} -setup {
clipboard clear
} -body {
clipboard append "Test"
clipboard append -t TEST "Test2"
clipboard append "Test3"
selection clear -s CLIPBOARD
clipboard get
} -cleanup {
clipboard clear
} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
test clipboard-4.5 {ClipboardLostSel procedure} -setup {
clipboard clear
} -body {
clipboard append "Test"
clipboard append -t TEST "Test2"
clipboard append "Test3"
selection clear -s CLIPBOARD
catch {clipboard get}
clipboard get -t TEST
} -cleanup {
clipboard clear
} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined}
##############################################################################
test clipboard-5.1 {Tk_ClipboardClear procedure} -setup {
clipboard clear
} -body {
clipboard append -t TEST "test"
set result [lsort [clipboard get TARGETS]]
clipboard clear
list $result [lsort [clipboard get TARGETS]]
} -cleanup {
clipboard clear
} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
test clipboard-5.2 {Tk_ClipboardClear procedure} -setup {
clipboard clear
} -body {
clipboard append -t TEST "test"
set result [lsort [clipboard get TARGETS]]
selection own -s CLIPBOARD .
lappend result [lsort [clipboard get TARGETS]]
clipboard clear
clipboard append -t TEST "test"
lappend result [lsort [clipboard get TARGETS]]
} -cleanup {
clipboard clear
} -result {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} -setup {
clipboard clear
} -body {
clipboard append "first chunk"
selection own -s CLIPBOARD .
clipboard append " second chunk"
clipboard get
} -cleanup {
clipboard clear
} -returnCodes ok -result {first chunk second chunk}
test clipboard-6.2 {Tk_ClipboardAppend procedure} -constraints unix -setup {
clipboard clear
} -body {
setupbg
clipboard append -f INTEGER -t TEST "16"
set result [dobg {clipboard get TEST}]
return $result
} -cleanup {
clipboard clear
cleanupbg
} -result {0x10 }
test clipboard-6.3 {Tk_ClipboardAppend procedure} -setup {
clipboard clear
} -body {
clipboard append -f INTEGER -t TEST "16"
clipboard append -t TEST "test"
} -cleanup {
clipboard clear
} -returnCodes error -result {format "STRING" does not match current format "INTEGER" for TEST}
##############################################################################
test clipboard-7.1 {Tk_ClipboardCmd procedure} -body {
clipboard
} -returnCodes error -result {wrong # args: should be "clipboard option ?arg ...?"}
test clipboard-7.2 {Tk_ClipboardCmd procedure} -setup {
clipboard clear
} -body {
clipboard append --
} -cleanup {
clipboard clear
} -returnCodes ok -result {}
test clipboard-7.3 {Tk_ClipboardCmd procedure} -setup {
clipboard clear
} -body {
clipboard append --
selection get -selection CLIPBOARD
} -cleanup {
clipboard clear
} -result {--}
test clipboard-7.4 {Tk_ClipboardCmd procedure} -setup {
clipboard clear
} -body {
clipboard append -- information
selection get -selection CLIPBOARD
} -cleanup {
clipboard clear
} -result {information}
test clipboard-7.5 {Tk_ClipboardCmd procedure} -body {
clipboard append --x a b
} -returnCodes error -result {bad option "--x": must be -displayof, -format, or -type}
test clipboard-7.6 {Tk_ClipboardCmd procedure} -body {
clipboard append -- a b
} -returnCodes error -result {wrong # args: should be "clipboard append ?-option value ...? data"}
test clipboard-7.7 {Tk_ClipboardCmd procedure} -setup {
clipboard clear
} -body {
clipboard append -format
} -returnCodes ok -result {}
test clipboard-7.8 {Tk_ClipboardCmd procedure} -setup {
clipboard clear
} -body {
clipboard append -format
selection get -selection CLIPBOARD
} -cleanup {
clipboard clear
} -result {-format}
test clipboard-7.9 {Tk_ClipboardCmd procedure} -body {
clipboard append -displayofoo f
} -returnCodes error -result {bad option "-displayofoo": must be -displayof, -format, or -type}
test clipboard-7.10 {Tk_ClipboardCmd procedure} -body {
clipboard append -type TEST
} -returnCodes error -result {wrong # args: should be "clipboard append ?-option value ...? data"}
test clipboard-7.11 {Tk_ClipboardCmd procedure} -body {
clipboard append -displayof foo "test"
} -returnCodes error -result {bad window path name "foo"}
test clipboard-7.12 {Tk_ClipboardCmd procedure} -body {
clipboard clear -displayof
} -returnCodes error -result {wrong # args: should be "clipboard clear ?-displayof window?"}
test clipboard-7.13 {Tk_ClipboardCmd procedure} -body {
clipboard clear -displayofoo f
} -returnCodes error -result {bad option "-displayofoo": must be -displayof}
test clipboard-7.14 {Tk_ClipboardCmd procedure} -body {
clipboard clear foo
} -returnCodes error -result {wrong # args: should be "clipboard clear ?-displayof window?"}
test clipboard-7.15 {Tk_ClipboardCmd procedure} -body {
clipboard clear -displayof foo
} -returnCodes error -result {bad window path name "foo"}
test clipboard-7.16 {Tk_ClipboardCmd procedure} -body {
clipboard error
} -returnCodes error -result {bad option "error": must be append, clear, or get}
test clipboard-7.17 {Tk_ClipboardCmd procedure} -setup {
clipboard clear
} -body {
clipboard append -displayof
} -cleanup {
clipboard clear
} -returnCodes ok -result {}
test clipboard-7.18 {Tk_ClipboardCmd procedure} -setup {
clipboard clear
} -body {
clipboard append -displayof
selection get -selection CLIPBOARD
} -cleanup {
clipboard clear
} -result {-displayof}
test clipboard-7.19 {Tk_ClipboardCmd procedure} -setup {
clipboard clear
} -body {
clipboard append -type
} -cleanup {
clipboard clear
} -returnCodes ok -result {}
test clipboard-7.20 {Tk_ClipboardCmd procedure} -setup {
clipboard clear
} -body {
clipboard append -type
selection get -selection CLIPBOARD
} -cleanup {
clipboard clear
} -result {-type}
# cleanup
cleanupTests
return
# Local Variables:
# mode: tcl
# End:

216
tests/clrpick.test Normal file
View File

@@ -0,0 +1,216 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
if {[testConstraint defaultPseudocolor8]} {
# let's soak up a bunch of colors...so that
# machines with small color palettes still fail.
# some tests will be skipped if there are no more colors
set numcolors 32
testConstraint colorsLeftover 1
set i 0
canvas .c
pack .c -expand 1 -fill both
while {$i<$numcolors} {
set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]]
.c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color
incr i
}
set i 0
while {$i<$numcolors} {
set color [.c itemcget $i -fill]
if {$color != ""} {
foreach {r g b} [winfo rgb . $color] {}
set r [expr $r/256]
set g [expr $g/256]
set b [expr $b/256]
if {"$color" != "#[format %02x%02x%02x $r $g $b]"} {
testConstraint colorsLeftover 0
}
}
.c delete $i
incr i
}
destroy .c
} else {
testConstraint colorsLeftover 0
}
test clrpick-1.1 {tk_chooseColor command} -body {
tk_chooseColor -foo
} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}
test clrpick-1.2 {tk_chooseColor command } -body {
tk_chooseColor -initialcolor
} -returnCodes error -result {value for "-initialcolor" missing}
test clrpick-1.2.1 {tk_chooseColor command } -body {
tk_chooseColor -parent
} -returnCodes error -result {value for "-parent" missing}
test clrpick-1.2.2 {tk_chooseColor command } -body {
tk_chooseColor -title
} -returnCodes error -result {value for "-title" missing}
test clrpick-1.3 {tk_chooseColor command} -body {
tk_chooseColor -foo bar
} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}
test clrpick-1.4 {tk_chooseColor command} -body {
tk_chooseColor -initialcolor
} -returnCodes error -result {value for "-initialcolor" missing}
test clrpick-1.5 {tk_chooseColor command} -body {
tk_chooseColor -parent foo.bar
} -returnCodes error -result {bad window path name "foo.bar"}
test clrpick-1.6 {tk_chooseColor command} -body {
tk_chooseColor -initialcolor badbadbaadcolor
} -returnCodes error -result {unknown color name "badbadbaadcolor"}
test clrpick-1.7 {tk_chooseColor command} -body {
tk_chooseColor -initialcolor ##badbadbaadcolor
} -returnCodes error -result {invalid color name "##badbadbaadcolor"}
# tests 3.1 and 3.2 fail when individually run
# if there is no catch {tk_chooseColor -foo 1} msg
# before settin isNative
catch {tk_chooseColor -foo 1} msg
set isNative [expr {[info commands tk::dialog::color::] eq ""}]
proc ToPressButton {parent btn} {
global isNative
if {!$isNative} {
after 200 "SendButtonPress . $btn mouse"
}
}
proc ToChooseColorByKey {parent r g b} {
global isNative
if {!$isNative} {
after 200 ChooseColorByKey . $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 ::tk::dialog::color::[winfo name $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.
tk::dialog::color::HandleRGBEntry $w
SendButtonPress . ok mouse
}
proc SendButtonPress {parent btn type} {
set w .__tk__color
upvar ::tk::dialog::color::[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
}
}
test clrpick-2.1 {tk_chooseColor command} -constraints {
nonUnixUserInteraction colorsLeftover
} -setup {
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
} -body {
ToPressButton . ok
tk_chooseColor -title "Press Ok $verylongstring" -initialcolor #404040 \
-parent .
} -result {#404040}
test clrpick-2.2 {tk_chooseColor command} -constraints {
nonUnixUserInteraction colorsLeftover
} -body {
set colors "128 128 64"
ToChooseColorByKey . 128 128 64
tk_chooseColor -parent . -title "choose #808040"
} -result {#808040}
test clrpick-2.3 {tk_chooseColor command} -constraints {
nonUnixUserInteraction colorsLeftover
} -body {
ToPressButton . ok
tk_chooseColor -parent . -title "Press OK"
} -result {#808040}
test clrpick-2.4 {tk_chooseColor command} -constraints {
nonUnixUserInteraction colorsLeftover
} -body {
ToPressButton . cancel
tk_chooseColor -parent . -title "Press Cancel"
} -result {}
test clrpick-3.1 {tk_chooseColor: background events} -constraints {
nonUnixUserInteraction
} -body {
after 1 {set x 53}
ToPressButton . ok
tk_chooseColor -parent . -title "Press OK" -initialcolor #000000
} -result {#000000}
test clrpick-3.2 {tk_chooseColor: background events} -constraints {
nonUnixUserInteraction
} -body {
after 1 {set x 53}
ToPressButton . cancel
tk_chooseColor -parent . -title "Press Cancel"
} -result {}
test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints {
unix notAqua
} -body {
after 50 {set ::scr [winfo screen .__tk__color]}
ToPressButton . cancel
tk_chooseColor -parent .
set ::scr
} -result [winfo screen .]
# cleanup
cleanupTests
return

72
tests/cmap.tcl Normal file
View File

@@ -0,0 +1,72 @@
# 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.
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

60
tests/cmds.test Normal file
View File

@@ -0,0 +1,60 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
update
test cmds-1.1 {tkwait visibility, argument errors} -body {
tkwait visibility
} -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"}
test cmds-1.2 {tkwait visibility, argument errors} -body {
tkwait visibility foo bar
} -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"}
test cmds-1.3 {tkwait visibility, argument errors} -body {
tkwait visibility bad_window
} -returnCodes {error} -result {bad window path name "bad_window"}
test cmds-1.4 {tkwait visibility, waiting for window to be mapped} -setup {
button .b -text "Test"
set x init
} -body {
after 100 {set x delay; place .b -x 0 -y 0}
tkwait visibility .b
return $x
} -cleanup {
destroy .b
} -result {delay}
test cmds-1.5 {tkwait visibility, window gets deleted} -setup {
frame .f
button .f.b -text "Test"
pack .f.b
set x init
} -body {
after 100 {set x deleted; destroy .f}
tkwait visibility .f.b
} -returnCodes {error} -result {window ".f.b" was deleted before its visibility changed}
test cmds-1.6 {tkwait visibility, window gets deleted} -setup {
frame .f
button .f.b -text "Test"
pack .f.b
set x init
} -body {
after 100 {set x deleted; destroy .f}
catch {tkwait visibility .f.b}
return $x
} -cleanup {
destroy .f
} -result {deleted}
# cleanup
cleanupTests
return

282
tests/color.test Normal file
View File

@@ -0,0 +1,282 @@
# 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-1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
# 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)
}
if {[testConstraint psuedocolor8]} {
toplevel .t -visual {pseudocolor 8} -colormap new
wm geom .t +0+0
mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
pack .t.c
update
testConstraint colorsFree [colorsFree .t.c 101 233 17]
if {[testConstraint colorsFree]} {
mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
pack .t.c2
testConstraint colorsFree [expr {![colorsFree .t.c]}]
}
destroy .t.c .t.c2
}
test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree {
set x green
lindex $x 0
destroy .b1
button .b1 -foreground $x -text .b1
lindex $x 0
testcolor green
} {{1 0}}
test color-1.2 {Tk_AllocColorFromObj - discard stale color} colorsFree {
set x green
destroy .b1 .b2
button .b1 -foreground $x -text First
destroy .b1
set result {}
lappend result [testcolor green]
button .b2 -foreground $x -text Second
lappend result [testcolor green]
} {{} {{1 1}}}
test color-1.3 {Tk_AllocColorFromObj - reuse existing color} colorsFree {
set x green
destroy .b1 .b2
button .b1 -foreground $x -text First
set result {}
lappend result [testcolor green]
button .b2 -foreground $x -text Second
pack .b1 .b2 -side top
lappend result [testcolor green]
} {{{1 1}} {{2 1}}}
test color-1.4 {Tk_AllocColorFromObj - try other colors in list} colorsFree {
set x purple
destroy .b1 .b2 .t.b
button .b1 -foreground $x -text First
pack .b1 -side top
set result {}
lappend result [testcolor purple]
button .t.b -foreground $x -text Second
pack .t.b -side top
lappend result [testcolor purple]
button .b2 -foreground $x -text Third
pack .b2 -side top
lappend result [testcolor purple]
} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
test color-1.5 {Color table} nonPortable {
set fd [open ../xlib/rgb.txt]
set result {}
while {[gets $fd line] != -1} {
if {[string index $line 0] == "!"} continue
set rgb [c255 [winfo rgb . [lrange $line 3 end]]]
if {$rgb != [lrange $line 0 2] } {
append result $line\n
}
}
return $result
} {}
test color-2.1 {Tk_GetColor procedure} colorsFree {
c255 [winfo rgb .t #FF0000]
} {255 0 0}
test color-2.2 {Tk_GetColor procedure} colorsFree {
list [catch {winfo rgb .t noname} msg] $msg
} {1 {unknown color name "noname"}}
test color-2.3 {Tk_GetColor procedure} colorsFree {
c255 [winfo rgb .t #123456]
} {18 52 86}
test color-2.4 {Tk_GetColor procedure} colorsFree {
list [catch {winfo rgb .t #xyz} msg] $msg
} {1 {invalid color name "#xyz"}}
test color-2.5 {Tk_GetColor procedure} colorsFree {
winfo rgb .t #00FF00
} {0 65535 0}
test color-2.6 {Tk_GetColor procedure} {colorsFree nonPortable} {
# Red doesn't always map to *pure* red
winfo rgb .t red
} {65535 0 0}
test color-2.7 {Tk_GetColor procedure} colorsFree {
winfo rgb .t #ff0000
} {65535 0 0}
test color-3.1 {Tk_FreeColor procedure, reference counting} colorsFree {
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-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} colorsFree {
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}
test color-3.3 {Tk_FreeColorFromObj - reference counts} colorsFree {
set x purple
destroy .b1 .b2 .t.b
button .b1 -foreground $x -text First
pack .b1 -side top
button .t.b -foreground $x -text Second
pack .t.b -side top
button .b2 -foreground $x -text Third
pack .b2 -side top
set result {}
lappend result [testcolor purple]
destroy .b1
lappend result [testcolor purple]
destroy .b2
lappend result [testcolor purple]
destroy .t.b
lappend result [testcolor purple]
} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
test color-3.4 {Tk_FreeColorFromObj - unlinking from list} colorsFree {
destroy .b .t.b .t2 .t3
toplevel .t2 -visual {pseudocolor 8} -colormap new
toplevel .t3 -visual {pseudocolor 8} -colormap new
set x purple
button .b -foreground $x -text .b1
button .t.b1 -foreground $x -text .t.b1
button .t.b2 -foreground $x -text .t.b2
button .t2.b1 -foreground $x -text .t2.b1
button .t2.b2 -foreground $x -text .t2.b2
button .t2.b3 -foreground $x -text .t2.b3
button .t3.b1 -foreground $x -text .t3.b1
button .t3.b2 -foreground $x -text .t3.b2
button .t3.b3 -foreground $x -text .t3.b3
button .t3.b4 -foreground $x -text .t3.b4
set result {}
lappend result [testcolor purple]
destroy .t2
lappend result [testcolor purple]
destroy .b
lappend result [testcolor purple]
destroy .t3
lappend result [testcolor purple]
destroy .t
lappend result [testcolor purple]
} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
test color-4.1 {FreeColorObjProc} colorsFree {
destroy .b
set x [format purple]
button .b -foreground $x -text .b1
set y [format purple]
.b configure -foreground $y
set z [format purple]
.b configure -foreground $z
set result {}
lappend result [testcolor purple]
set x red
lappend result [testcolor purple]
set z 32
lappend result [testcolor purple]
destroy .b
lappend result [testcolor purple]
set y bogus
set result
} {{{1 3}} {{1 2}} {{1 1}} {}}
destroy .t
# cleanup
cleanupTests
return

1929
tests/config.test Normal file
View File

File diff suppressed because it is too large Load Diff

282
tests/constraints.tcl Normal file
View File

@@ -0,0 +1,282 @@
if {[namespace exists tk::test]} {
deleteWindows
wm geometry . {}
raise .
return
}
package require Tk 8.4
tk appname tktest
wm title . tktest
# 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
}
package require tcltest 2.1
namespace eval tk {
namespace eval test {
namespace export loadTkCommand
proc loadTkCommand {} {
set tklib {}
foreach pair [info loaded {}] {
foreach {lib pfx} $pair break
if {$pfx eq "Tk"} {
set tklib $lib
break
}
}
return [list load $tklib Tk]
}
namespace eval bg {
# Manage a background process.
# Replace with slave interp or thread?
namespace import ::tcltest::interpreter
namespace import ::tk::test::loadTkCommand
namespace export setup cleanup do
proc cleanup {} {
variable fd
# catch in case the background process has closed $fd
catch {puts $fd exit}
catch {close $fd}
set fd ""
}
proc setup args {
variable fd
if {[info exists fd] && [string length $fd]} {
cleanup
}
set fd [open "|[list [interpreter] \
-geometry +0+0 -name tktest] $args" r+]
puts $fd "puts foo; flush stdout"
flush $fd
if {[gets $fd data] < 0} {
error "unexpected EOF from \"[interpreter]\""
}
if {$data ne "foo"} {
error "unexpected output from\
background process: \"$data\""
}
puts $fd [loadTkCommand]
flush $fd
fileevent $fd readable [namespace code Ready]
}
proc Ready {} {
variable fd
variable Data
variable Done
set x [gets $fd]
if {[eof $fd]} {
fileevent $fd readable {}
set Done 1
} elseif {$x eq "**DONE**"} {
set Done 1
} else {
append Data $x
}
}
proc do {cmd {block 0}} {
variable fd
variable Data
variable Done
if {$block} {
fileevent $fd readable {}
}
puts $fd "[list catch $cmd msg]; update; puts \$msg;\
puts **DONE**; flush stdout"
flush $fd
set Data {}
if {$block} {
while {![eof $fd]} {
set line [gets $fd]
if {$line eq "**DONE**"} {
break
}
append Data $line
}
} else {
set Done 0
vwait [namespace which -variable Done]
}
return $Data
}
}
proc Export {internal as external} {
uplevel 1 [list namespace import $internal]
uplevel 1 [list rename [namespace tail $internal] $external]
uplevel 1 [list namespace export $external]
}
Export bg::setup as setupbg
Export bg::cleanup as cleanupbg
Export bg::do as dobg
namespace export deleteWindows
proc deleteWindows {} {
eval destroy [winfo children .]
}
namespace export fixfocus
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
}
namespace export imageInit imageFinish imageCleanup imageNames
variable ImageNames
proc imageInit {} {
variable ImageNames
if {![info exists ImageNames]} {
set ImageNames [lsort [image names]]
}
imageCleanup
if {[lsort [image names]] ne $ImageNames} {
return -code error "IMAGE NAMES mismatch: [image names] != $ImageNames"
}
}
proc imageFinish {} {
variable ImageNames
if {[lsort [image names]] ne $ImageNames} {
return -code error "images remaining: [image names] != $ImageNames"
}
imageCleanup
}
proc imageCleanup {} {
variable ImageNames
foreach img [image names] {
if {$img ni $ImageNames} {image delete $img}
}
}
proc imageNames {} {
variable ImageNames
set r {}
foreach img [image names] {
if {$img ni $ImageNames} {lappend r $img}
}
return $r
}
}
}
namespace import -force tk::test::*
namespace import -force tcltest::testConstraint
testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}]
testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}]
testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}]
testConstraint userInteraction 0
testConstraint nonUnixUserInteraction [expr {
[testConstraint userInteraction] ||
([testConstraint unix] && [testConstraint notAqua])
}]
testConstraint haveDISPLAY [info exists env(DISPLAY)]
testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)]
testConstraint noExceed [expr {
![testConstraint unix] || [catch {font actual "\{xyz"}]
}]
# constraints for testing facilities defined in the tktest executable...
testConstraint testImageType [expr {[lsearch [image types] test] >= 0}]
testConstraint testOldImageType [expr {[lsearch [image types] oldtest] >= 0}]
testConstraint testbitmap [llength [info commands testbitmap]]
testConstraint testborder [llength [info commands testborder]]
testConstraint testcbind [llength [info commands testcbind]]
testConstraint testclipboard [llength [info commands testclipboard]]
testConstraint testcolor [llength [info commands testcolor]]
testConstraint testcursor [llength [info commands testcursor]]
testConstraint testembed [llength [info commands testembed]]
testConstraint testfont [llength [info commands testfont]]
testConstraint testmakeexist [llength [info commands testmakeexist]]
testConstraint testmenubar [llength [info commands testmenubar]]
testConstraint testmetrics [llength [info commands testmetrics]]
testConstraint testobjconfig [llength [info commands testobjconfig]]
testConstraint testsend [llength [info commands testsend]]
testConstraint testtext [llength [info commands testtext]]
testConstraint testwinevent [llength [info commands testwinevent]]
testConstraint testwrapper [llength [info commands testwrapper]]
# constraint to see what sort of fonts are available
testConstraint fonts 1
destroy .e
entry .e -width 0 -font {Helvetica -12} -bd 1 -highlightthickness 1
.e insert end a.bcd
if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
testConstraint fonts 0
}
destroy .e
destroy .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]} {
testConstraint fonts 0
}
testConstraint textfonts [expr {
[testConstraint fonts] || [tk windowingsystem] eq "win32"
}]
# constraints for the visuals available..
testConstraint pseudocolor8 [expr {
([catch {
toplevel .t -visual {pseudocolor 8} -colormap new
}] == 0) && ([winfo depth .t] == 8)
}]
destroy .t
testConstraint haveTruecolor24 [expr {
[lsearch -exact [winfo visualsavailable .] {truecolor 24}] >= 0
}]
testConstraint haveGrayscale8 [expr {
[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0
}]
testConstraint defaultPseudocolor8 [expr {
([winfo visual .] eq "pseudocolor") && ([winfo depth .] == 8)
}]
# constraint based on whether our display is secure
setupbg
set app [dobg {tk appname}]
testConstraint secureserver 0
if {[llength [info commands send]]} {
testConstraint secureserver 1
if {[catch {send $app set a 0} msg] == 1} {
if {[string match "X server insecure *" $msg]} {
testConstraint secureserver 0
}
}
}
cleanupbg
eval tcltest::configure $argv
namespace import -force tcltest::test
namespace import -force tcltest::makeFile
namespace import -force tcltest::removeFile
namespace import -force tcltest::makeDirectory
namespace import -force tcltest::removeDirectory
namespace import -force tcltest::interpreter
namespace import -force tcltest::testsDirectory
namespace import -force tcltest::cleanupTests
deleteWindows
wm geometry . {}
raise .

843
tests/cursor.test Normal file
View File

@@ -0,0 +1,843 @@
# This file is a Tcl script to test out the procedures in the file
# tkCursor.c. It is organized in the standard white-box fashion for
# Tcl tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
# Tests 2.3 and 2.4 need a helper file with a very specific name and
# controlled format.
proc setWincur {wincurName} {
upvar $wincurName wincur
set wincur(data_octal) {
000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000
000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036
000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360
000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370
000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016
000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300
377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007
377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003
377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340
377 377 017 360 377 377
}
set wincur(data_binary) {}
foreach wincur(num) $wincur(data_octal) {
append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
}
set wincur(dir) [makeDirectory {dir with spaces}]
set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
}
test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints {
testcursor
} -body {
set x watch
lindex $x 0
button .b -cursor $x
lindex $x 0
testcursor watch
} -cleanup {
destroy .b
} -result {{1 0}}
test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} -constraints {
testcursor
} -body {
set x watch
set result {}
button .b1 -cursor $x
destroy .b1
lappend result [testcursor watch]
button .b2 -cursor $x
lappend result [testcursor watch]
} -cleanup {
destroy .b2
} -result {{} {{1 1}}}
test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} -constraints {
testcursor
} -body {
set x watch
set result {}
button .b1 -cursor $x
lappend result [testcursor watch]
button .b2 -cursor $x
pack .b1 .b2 -side top
lappend result [testcursor watch]
} -cleanup {
destroy .b1 .b2
} -result {{{1 1}} {{2 1}}}
test cursor-2.1 {Tk_GetCursor procedure} -body {
button .b -cursor bad_name
} -cleanup {
destroy .b
} -returnCodes error -result {bad cursor spec "bad_name"}
test cursor-2.2 {Tk_GetCursor procedure} -body {
button .b -cursor @xyzzy
} -cleanup {
destroy .b
} -returnCodes error -result {bad cursor spec "@xyzzy"}
test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} -constraints {
win
} -setup {
unset -nocomplain wincur
set wincur(file) ""
} -body {
setWincur wincur
button .b -cursor [list @$wincur(file)]
} -cleanup {
destroy .b
removeDirectory $wincur(dir)
unset wincur
} -result {.b}
test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} -constraints {
win
} -setup {
unset -nocomplain wincur
set wincur(file) ""
} -body {
setWincur wincur
button .b -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
} -cleanup {
destroy .b
removeDirectory $wincur(dir)
unset wincur
} -result {.b}
test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} -constraints {
testcursor
} -setup {
set x heart
set result {}
} -body {
button .b1 -cursor $x
button .b3 -cursor $x
button .b2 -cursor $x
lappend result [testcursor heart]
destroy .b1
lappend result [testcursor heart]
destroy .b2
lappend result [testcursor heart]
destroy .b3
lappend result [testcursor heart]
} -result {{{3 1}} {{2 1}} {{1 1}} {}}
test cursor-4.1 {FreeCursorObjProc} -constraints {
testcursor
} -body {
set x [join heart]
button .b -cursor $x
set y [join heart]
.b configure -cursor $y
set z [join heart]
.b configure -cursor $z
set result {}
lappend result [testcursor heart]
set x red
lappend result [testcursor heart]
set z 32
lappend result [testcursor heart]
destroy .b
lappend result [testcursor heart]
set y bogus
set result
} -cleanup {
destroy .b
} -result {{{1 3}} {{1 2}} {{1 1}} {}}
# -------------------------------------------------------------------------
test cursor-5.1 {assert consistent cursor configuration command} -setup {
button .b
} -body {
.b configure -cursor {watch red black}
} -cleanup {
destroy .b
} -result {}
# -------------------------------------------------------------------------
# Check for the standard set of cursors.
test cursor-6.1 {check cursor-font cursor X_cursor} -setup {
button .b -text X_cursor
} -body {
.b configure -cursor X_cursor
} -cleanup {
destroy .b
} -result {}
test cursor-6.2 {check cursor-font cursor arrow} -setup {
button .b -text arrow
} -body {
.b configure -cursor arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.3 {check cursor-font cursor based_arrow_down} -setup {
button .b -text based_arrow_down
} -body {
.b configure -cursor based_arrow_down
} -cleanup {
destroy .b
} -result {}
test cursor-6.4 {check cursor-font cursor based_arrow_up} -setup {
button .b -text based_arrow_up
} -body {
.b configure -cursor based_arrow_up
} -cleanup {
destroy .b
} -result {}
test cursor-6.5 {check cursor-font cursor boat} -setup {
button .b -text boat
} -body {
.b configure -cursor boat
} -cleanup {
destroy .b
} -result {}
test cursor-6.6 {check cursor-font cursor bogosity} -setup {
button .b -text bogosity
} -body {
.b configure -cursor bogosity
} -cleanup {
destroy .b
} -result {}
test cursor-6.7 {check cursor-font cursor bottom_left_corner} -setup {
button .b -text bottom_left_corner
} -body {
.b configure -cursor bottom_left_corner
} -cleanup {
destroy .b
} -result {}
test cursor-6.8 {check cursor-font cursor bottom_right_corner} -setup {
button .b -text bottom_right_corner
} -body {
.b configure -cursor bottom_right_corner
} -cleanup {
destroy .b
} -result {}
test cursor-6.9 {check cursor-font cursor bottom_side} -setup {
button .b -text bottom_side
} -body {
.b configure -cursor bottom_side
} -cleanup {
destroy .b
} -result {}
test cursor-6.10 {check cursor-font cursor bottom_tee} -setup {
button .b -text bottom_tee
} -body {
.b configure -cursor bottom_tee
} -cleanup {
destroy .b
} -result {}
test cursor-6.11 {check cursor-font cursor box_spiral} -setup {
button .b -text box_spiral
} -body {
.b configure -cursor box_spiral
} -cleanup {
destroy .b
} -result {}
test cursor-6.12 {check cursor-font cursor center_ptr} -setup {
button .b -text center_ptr
} -body {
.b configure -cursor center_ptr
} -cleanup {
destroy .b
} -result {}
test cursor-6.13 {check cursor-font cursor circle} -setup {
button .b -text circle
} -body {
.b configure -cursor circle
} -cleanup {
destroy .b
} -result {}
test cursor-6.14 {check cursor-font cursor clock} -setup {
button .b -text clock
} -body {
.b configure -cursor clock
} -cleanup {
destroy .b
} -result {}
test cursor-6.15 {check cursor-font cursor coffee_mug} -setup {
button .b -text coffee_mug
} -body {
.b configure -cursor coffee_mug
} -cleanup {
destroy .b
} -result {}
test cursor-6.16 {check cursor-font cursor cross} -setup {
button .b -text cross
} -body {
.b configure -cursor cross
} -cleanup {
destroy .b
} -result {}
test cursor-6.17 {check cursor-font cursor cross_reverse} -setup {
button .b -text cross_reverse
} -body {
.b configure -cursor cross_reverse
} -cleanup {
destroy .b
} -result {}
test cursor-6.18 {check cursor-font cursor crosshair} -setup {
button .b -text crosshair
} -body {
.b configure -cursor crosshair
} -cleanup {
destroy .b
} -result {}
test cursor-6.19 {check cursor-font cursor diamond_cross} -setup {
button .b -text diamond_cross
} -body {
.b configure -cursor diamond_cross
} -cleanup {
destroy .b
} -result {}
test cursor-6.20 {check cursor-font cursor dot} -setup {
button .b -text dot
} -body {
.b configure -cursor dot
} -cleanup {
destroy .b
} -result {}
test cursor-6.21 {check cursor-font cursor dotbox} -setup {
button .b -text dotbox
} -body {
.b configure -cursor dotbox
} -cleanup {
destroy .b
} -result {}
test cursor-6.22 {check cursor-font cursor double_arrow} -setup {
button .b -text double_arrow
} -body {
.b configure -cursor double_arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.23 {check cursor-font cursor draft_large} -setup {
button .b -text draft_large
} -body {
.b configure -cursor draft_large
} -cleanup {
destroy .b
} -result {}
test cursor-6.24 {check cursor-font cursor draft_small} -setup {
button .b -text draft_small
} -body {
.b configure -cursor draft_small
} -cleanup {
destroy .b
} -result {}
test cursor-6.25 {check cursor-font cursor draped_box} -setup {
button .b -text draped_box
} -body {
.b configure -cursor draped_box
} -cleanup {
destroy .b
} -result {}
test cursor-6.26 {check cursor-font cursor exchange} -setup {
button .b -text exchange
} -body {
.b configure -cursor exchange
} -cleanup {
destroy .b
} -result {}
test cursor-6.27 {check cursor-font cursor fleur} -setup {
button .b -text fleur
} -body {
.b configure -cursor fleur
} -cleanup {
destroy .b
} -result {}
test cursor-6.28 {check cursor-font cursor gobbler} -setup {
button .b -text gobbler
} -body {
.b configure -cursor gobbler
} -cleanup {
destroy .b
} -result {}
test cursor-6.29 {check cursor-font cursor gumby} -setup {
button .b -text gumby
} -body {
.b configure -cursor gumby
} -cleanup {
destroy .b
} -result {}
test cursor-6.30 {check cursor-font cursor hand1} -setup {
button .b -text hand1
} -body {
.b configure -cursor hand1
} -cleanup {
destroy .b
} -result {}
test cursor-6.31 {check cursor-font cursor hand2} -setup {
button .b -text hand2
} -body {
.b configure -cursor hand2
} -cleanup {
destroy .b
} -result {}
test cursor-6.32 {check cursor-font cursor heart} -setup {
button .b -text heart
} -body {
.b configure -cursor heart
} -cleanup {
destroy .b
} -result {}
test cursor-6.33 {check cursor-font cursor icon} -setup {
button .b -text icon
} -body {
.b configure -cursor icon
} -cleanup {
destroy .b
} -result {}
test cursor-6.34 {check cursor-font cursor iron_cross} -setup {
button .b -text iron_cross
} -body {
.b configure -cursor iron_cross
} -cleanup {
destroy .b
} -result {}
test cursor-6.35 {check cursor-font cursor left_ptr} -setup {
button .b -text left_ptr
} -body {
.b configure -cursor left_ptr
} -cleanup {
destroy .b
} -result {}
test cursor-6.36 {check cursor-font cursor left_side} -setup {
button .b -text left_side
} -body {
.b configure -cursor left_side
} -cleanup {
destroy .b
} -result {}
test cursor-6.37 {check cursor-font cursor left_tee} -setup {
button .b -text left_tee
} -body {
.b configure -cursor left_tee
} -cleanup {
destroy .b
} -result {}
test cursor-6.38 {check cursor-font cursor leftbutton} -setup {
button .b -text leftbutton
} -body {
.b configure -cursor leftbutton
} -cleanup {
destroy .b
} -result {}
test cursor-6.39 {check cursor-font cursor ll_angle} -setup {
button .b -text ll_angle
} -body {
.b configure -cursor ll_angle
} -cleanup {
destroy .b
} -result {}
test cursor-6.40 {check cursor-font cursor lr_angle} -setup {
button .b -text lr_angle
} -body {
.b configure -cursor lr_angle
} -cleanup {
destroy .b
} -result {}
test cursor-6.41 {check cursor-font cursor man} -setup {
button .b -text man
} -body {
.b configure -cursor man
} -cleanup {
destroy .b
} -result {}
test cursor-6.42 {check cursor-font cursor middlebutton} -setup {
button .b -text middlebutton
} -body {
.b configure -cursor middlebutton
} -cleanup {
destroy .b
} -result {}
test cursor-6.43 {check cursor-font cursor mouse} -setup {
button .b -text mouse
} -body {
.b configure -cursor mouse
} -cleanup {
destroy .b
} -result {}
test cursor-6.44 {check cursor-font cursor pencil} -setup {
button .b -text pencil
} -body {
.b configure -cursor pencil
} -cleanup {
destroy .b
} -result {}
test cursor-6.45 {check cursor-font cursor pirate} -setup {
button .b -text pirate
} -body {
.b configure -cursor pirate
} -cleanup {
destroy .b
} -result {}
test cursor-6.46 {check cursor-font cursor plus} -setup {
button .b -text plus
} -body {
.b configure -cursor plus
} -cleanup {
destroy .b
} -result {}
test cursor-6.47 {check cursor-font cursor question_arrow} -setup {
button .b -text question_arrow
} -body {
.b configure -cursor question_arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.48 {check cursor-font cursor right_ptr} -setup {
button .b -text right_ptr
} -body {
.b configure -cursor right_ptr
} -cleanup {
destroy .b
} -result {}
test cursor-6.49 {check cursor-font cursor right_side} -setup {
button .b -text right_side
} -body {
.b configure -cursor right_side
} -cleanup {
destroy .b
} -result {}
test cursor-6.50 {check cursor-font cursor right_tee} -setup {
button .b -text right_tee
} -body {
.b configure -cursor right_tee
} -cleanup {
destroy .b
} -result {}
test cursor-6.51 {check cursor-font cursor rightbutton} -setup {
button .b -text rightbutton
} -body {
.b configure -cursor rightbutton
} -cleanup {
destroy .b
} -result {}
test cursor-6.52 {check cursor-font cursor rtl_logo} -setup {
button .b -text rtl_logo
} -body {
.b configure -cursor rtl_logo
} -cleanup {
destroy .b
} -result {}
test cursor-6.53 {check cursor-font cursor sailboat} -setup {
button .b -text sailboat
} -body {
.b configure -cursor sailboat
} -cleanup {
destroy .b
} -result {}
test cursor-6.54 {check cursor-font cursor sb_down_arrow} -setup {
button .b -text sb_down_arrow
} -body {
.b configure -cursor sb_down_arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.55 {check cursor-font cursor sb_h_double_arrow} -setup {
button .b -text sb_h_double_arrow
} -body {
.b configure -cursor sb_h_double_arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.56 {check cursor-font cursor sb_left_arrow} -setup {
button .b -text sb_left_arrow
} -body {
.b configure -cursor sb_left_arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.57 {check cursor-font cursor sb_right_arrow} -setup {
button .b -text sb_right_arrow
} -body {
.b configure -cursor sb_right_arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.58 {check cursor-font cursor sb_up_arrow} -setup {
button .b -text sb_up_arrow
} -body {
.b configure -cursor sb_up_arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.59 {check cursor-font cursor sb_v_double_arrow} -setup {
button .b -text sb_v_double_arrow
} -body {
.b configure -cursor sb_v_double_arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.60 {check cursor-font cursor shuttle} -setup {
button .b -text shuttle
} -body {
.b configure -cursor shuttle
} -cleanup {
destroy .b
} -result {}
test cursor-6.61 {check cursor-font cursor sizing} -setup {
button .b -text sizing
} -body {
.b configure -cursor sizing
} -cleanup {
destroy .b
} -result {}
test cursor-6.62 {check cursor-font cursor spider} -setup {
button .b -text spider
} -body {
.b configure -cursor spider
} -cleanup {
destroy .b
} -result {}
test cursor-6.63 {check cursor-font cursor spraycan} -setup {
button .b -text spraycan
} -body {
.b configure -cursor spraycan
} -cleanup {
destroy .b
} -result {}
test cursor-6.64 {check cursor-font cursor star} -setup {
button .b -text star
} -body {
.b configure -cursor star
} -cleanup {
destroy .b
} -result {}
test cursor-6.65 {check cursor-font cursor target} -setup {
button .b -text target
} -body {
.b configure -cursor target
} -cleanup {
destroy .b
} -result {}
test cursor-6.66 {check cursor-font cursor tcross} -setup {
button .b -text tcross
} -body {
.b configure -cursor tcross
} -cleanup {
destroy .b
} -result {}
test cursor-6.67 {check cursor-font cursor top_left_arrow} -setup {
button .b -text top_left_arrow
} -body {
.b configure -cursor top_left_arrow
} -cleanup {
destroy .b
} -result {}
test cursor-6.68 {check cursor-font cursor top_left_corner} -setup {
button .b -text top_left_corner
} -body {
.b configure -cursor top_left_corner
} -cleanup {
destroy .b
} -result {}
test cursor-6.69 {check cursor-font cursor top_right_corner} -setup {
button .b -text top_right_corner
} -body {
.b configure -cursor top_right_corner
} -cleanup {
destroy .b
} -result {}
test cursor-6.70 {check cursor-font cursor top_side} -setup {
button .b -text top_side
} -body {
.b configure -cursor top_side
} -cleanup {
destroy .b
} -result {}
test cursor-6.71 {check cursor-font cursor top_tee} -setup {
button .b -text top_tee
} -body {
.b configure -cursor top_tee
} -cleanup {
destroy .b
} -result {}
test cursor-6.72 {check cursor-font cursor trek} -setup {
button .b -text trek
} -body {
.b configure -cursor trek
} -cleanup {
destroy .b
} -result {}
test cursor-6.73 {check cursor-font cursor ul_angle} -setup {
button .b -text ul_angle
} -body {
.b configure -cursor ul_angle
} -cleanup {
destroy .b
} -result {}
test cursor-6.74 {check cursor-font cursor umbrella} -setup {
button .b -text umbrella
} -body {
.b configure -cursor umbrella
} -cleanup {
destroy .b
} -result {}
test cursor-6.75 {check cursor-font cursor ur_angle} -setup {
button .b -text ur_angle
} -body {
.b configure -cursor ur_angle
} -cleanup {
destroy .b
} -result {}
test cursor-6.76 {check cursor-font cursor watch} -setup {
button .b -text watch
} -body {
.b configure -cursor watch
} -cleanup {
destroy .b
} -result {}
test cursor-6.77 {check cursor-font cursor xterm} -setup {
button .b -text xterm
} -body {
.b configure -cursor xterm
} -cleanup {
destroy .b
} -result {}
# Test cursor named "none", it is not defined in
# the X cursor table. It is defined in a Tk specific
# table of named cursors and should be available on
# all platforms.
test cursor-6.78 {test cursor named "none"} -setup {
button .b -text CButton
} -body {
.b configure -cursor none
.b cget -cursor
} -cleanup {
destroy .b
} -result none
test cursor-6.79 {test cursor named "none"} -setup {
button .b -text CButton
} -body {
.b configure -cursor none
.b configure -cursor {}
.b cget -cursor
} -cleanup {
destroy .b
} -result {}
test cursor-6.80 {test cursor named "none"} -setup {
button .b -text CButton
} -body {
.b configure -cursor none
.b configure -cursor {}
.b configure -cursor none
.b cget -cursor
} -cleanup {
destroy .b
} -result none
test cursor-6.81 {test cursor named "none"} -setup {
button .b -text CButton
} -body {
# Setting fg and bg does nothing for the none cursor
# because it displays no fg or bg pixels.
set results [list]
.b configure -cursor none
lappend results [.b cget -cursor]
.b configure -cursor {none blue}
lappend results [.b cget -cursor]
.b configure -cursor {none blue green}
lappend results [.b cget -cursor]
.b configure -cursor {}
lappend results [.b cget -cursor]
set results
} -cleanup {
destroy .b
unset results
} -result {none {none blue} {none blue green} {}}
# -------------------------------------------------------------------------
# Check the Windows specific cursors
test cursor-7.1 {check Windows cursor no} -constraints win -setup {
button .b -text no
} -body {
.b configure -cursor no
} -cleanup {
destroy .b
} -result {}
test cursor-7.2 {check Windows cursor starting} -constraints win -setup {
button .b -text starting
} -body {
.b configure -cursor starting
} -cleanup {
destroy .b
} -result {}
test cursor-7.3 {check Windows cursor size} -constraints win -setup {
button .b -text size
} -body {
.b configure -cursor size
} -cleanup {
destroy .b
} -result {}
test cursor-7.4 {check Windows cursor size_ne_sw} -constraints win -setup {
button .b -text size_ne_sw
} -body {
.b configure -cursor size_ne_sw
} -cleanup {
destroy .b
} -result {}
test cursor-7.5 {check Windows cursor size_ns} -constraints win -setup {
button .b -text size_ns
} -body {
.b configure -cursor size_ns
} -cleanup {
destroy .b
} -result {}
test cursor-7.6 {check Windows cursor size_nw_se} -constraints win -setup {
button .b -text size_nw_se
} -body {
.b configure -cursor size_nw_se
} -cleanup {
destroy .b
} -result {}
test cursor-7.7 {check Windows cursor size_we} -constraints win -setup {
button .b -text size_we
} -body {
.b configure -cursor size_we
} -cleanup {
destroy .b
} -result {}
test cursor-7.8 {check Windows cursor uparrow} -constraints win -setup {
button .b -text uparrow
} -body {
.b configure -cursor uparrow
} -cleanup {
destroy .b
} -result {}
test cursor-7.9 {check Windows cursor wait} -constraints win -setup {
button .b -text wait
} -body {
.b configure -cursor wait
} -cleanup {
destroy .b
} -result {}
# -------------------------------------------------------------------------
# cleanup
cleanupTests
return

67
tests/dialog.test Normal file
View File

@@ -0,0 +1,67 @@
# This file is a Tcl script to test out Tk's "tk_dialog" command.
# It is organized in the standard fashion for Tcl tests.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
test dialog-1.1 {tk_dialog command} -body {
tk_dialog
} -match glob -returnCodes error -result {wrong # args: should be "tk_dialog w title text bitmap default *"}
test dialog-1.2 {tk_dialog command} -body {
tk_dialog foo foo foo foo foo
} -returnCodes error -result {bad window path name "foo"}
test dialog-1.3 {tk_dialog command} -body {
tk_dialog .d foo foo fooBitmap foo
} -cleanup {
destroy .d
} -returnCodes error -result {bitmap "fooBitmap" not defined}
test dialog-2.1 {tk_dialog operation} -setup {
proc PressButton {btn} {
if {![winfo ismapped $btn]} {
update
}
event generate $btn <Enter>
event generate $btn <1> -x 5 -y 5
event generate $btn <ButtonRelease-1> -x 5 -y 5
}
} -body {
set x [after 5000 [list set tk::Priv(button) "no response"]]
after 100 PressButton .d.button0
set res [tk_dialog .d foo foo info 0 click]
after cancel $x
return $res
} -cleanup {
destroy .d
} -result {0}
test dialog-2.2 {tk_dialog operation} -setup {
proc HitReturn {w} {
event generate $w <Enter>
focus -force $w
event generate $w <KeyPress> -keysym Return
}
} -body {
set x [after 5000 [list set tk::Priv(button) "no response"]]
after 100 HitReturn .d
set res [tk_dialog .d foo foo info 1 click default]
after cancel $x
return $res
} -cleanup {
destroy .d
} -result {1}
test dialog-2.3 {tk_dialog operation} -body {
set x [after 5000 [list set tk::Priv(button) "no response"]]
after 100 destroy .d
set res [tk_dialog .d foo foo info 0 click]
after cancel $x
return $res
} -cleanup {
destroy .b
} -result {-1}
cleanupTests
return

BIN
tests/earth.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 50 KiB

88
tests/embed.test Normal file
View File

@@ -0,0 +1,88 @@
# This file is a Tcl script to test out embedded Windows.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test embed-1.1 {TkpUseWindow procedure, bad window identifier} -setup {
deleteWindows
} -body {
toplevel .t -use xyz
} -cleanup {
deleteWindows
} -returnCodes error -result {expected integer but got "xyz"}
test embed-1.2 {CreateFrame procedure, bad window identifier} -setup {
deleteWindows
} -body {
toplevel .t -container xyz
} -cleanup {
deleteWindows
} -returnCodes error -result {expected boolean value but got "xyz"}
test embed-1.3 {CreateFrame procedure, both -use and -container is invalid} -setup {
deleteWindows
} -body {
toplevel .container -container 1
toplevel .t -use [winfo id .container] -container 1
} -cleanup {
deleteWindows
} -returnCodes error -result {windows cannot have both the -use and the -container option set}
# testing window embedding for win platforms
test embed-1.4.win {TkpUseWindow procedure, -container must be set} -constraints {
win
} -setup {
deleteWindows
} -body {
toplevel .container
toplevel .embd -use [winfo id .container]
} -cleanup {
deleteWindows
} -returnCodes error -result {the window to use is not a Tk container}
# testing window embedding for win platforms
test embed-1.5.win {TkpUseWindow procedure, -container must be set} -constraints {
win
} -setup {
deleteWindows
} -body {
frame .container
toplevel .embd -use [winfo id .container]
} -cleanup {
deleteWindows
} -returnCodes error -result {the window to use is not a Tk container}
# testing window embedding for other than win platforms
test embed-1.4.nonwin {TkpUseWindow procedure, -container must be set} -constraints {
nonwin
} -setup {
deleteWindows
} -body {
toplevel .container
toplevel .embd -use [winfo id .container]
} -cleanup {
deleteWindows
} -returnCodes error -result {window ".container" doesn't have -container option set}
# testing window embedding for other than win platforms
test embed-1.5.nonwin {TkpUseWindow procedure, -container must be set} -constraints {
nonwin
} -setup {
deleteWindows
} -body {
frame .container
toplevel .embd -use [winfo id .container]
} -cleanup {
deleteWindows
} -returnCodes error -result {window ".container" doesn't have -container option set}
cleanupTests
return

3518
tests/entry.test Normal file
View File

File diff suppressed because it is too large Load Diff

837
tests/event.test Normal file
View File

@@ -0,0 +1,837 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
# 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.
# Setup table used to query key events.
proc _init_keypress_lookup {} {
global keypress_lookup
scan A %c start
scan Z %c finish
for {set i $start} {$i <= $finish} {incr i} {
set l [format %c $i]
set keypress_lookup($l) $l
}
scan a %c start
scan z %c finish
for {set i $start} {$i <= $finish} {incr i} {
set l [format %c $i]
set keypress_lookup($l) $l
}
scan 0 %c start
scan 9 %c finish
for {set i $start} {$i <= $finish} {incr i} {
set l [format %c $i]
set keypress_lookup($l) $l
}
# Most punctuation
array set keypress_lookup {
! exclam
% percent
& ampersand
( parenleft
) parenright
* asterisk
+ plus
, comma
- minus
. period
/ slash
: colon
< less
= equal
> greater
? question
@ at
^ asciicircum
_ underscore
| bar
~ asciitilde
' apostrophe
}
# Characters with meaning to Tcl...
array set keypress_lookup [list \
\" quotedbl \
\# numbersign \
\$ dollar \
\; semicolon \
\[ bracketleft \
\\ backslash \
\] bracketright \
\{ braceleft \
\} braceright \
" " space \
"\n" Return \
"\t" Tab]
}
# Lookup an event in the keypress table.
# For example:
# Q -> Q
# . -> period
# / -> slash
# Delete -> Delete
# Escape -> Escape
proc _keypress_lookup {char} {
global keypress_lookup
if {! [info exists keypress_lookup]} {
_init_keypress_lookup
}
if {$char == ""} {
error "empty char"
}
if {[info exists keypress_lookup($char)]} {
return $keypress_lookup($char)
} else {
return $char
}
}
# Lookup and generate a pair of KeyPress and KeyRelease events
proc _keypress {win key} {
set keysym [_keypress_lookup $key]
# Force focus to the window before delivering
# each event so that a window manager using
# a focus follows mouse will not steal away
# the focus if the mouse is moved around.
if {[focus] != $win} {
focus -force $win
}
event generate $win <KeyPress-$keysym>
_pause 50
if {[focus] != $win} {
focus -force $win
}
event generate $win <KeyRelease-$keysym>
_pause 50
}
# Call _keypress for each character in the given string
proc _keypress_string {win string} {
foreach letter [split $string ""] {
_keypress $win $letter
}
}
# Delay script execution for a given amount of time
proc _pause {{msecs 1000}} {
global _pause
if {! [info exists _pause(number)]} {
set _pause(number) 0
}
set num [incr _pause(number)]
set _pause($num) 0
after $msecs "set _pause($num) 1"
vwait _pause($num)
unset _pause($num)
}
# Helper proc to convert index to x y position
proc _text_ind_to_x_y {text ind} {
set bbox [$text bbox $ind]
if {[llength $bbox] != 4} {
error "got bbox \{$bbox\} from $text, index $ind"
}
foreach {x1 y1 width height} $bbox break
set middle_y [expr {$y1 + ($height / 2)}]
return [list $x1 $middle_y]
}
# Return selection only if owned by the given widget
proc _get_selection {widget} {
if {[string compare $widget [selection own]] != 0} {
return ""
}
if {[catch {selection get} sel]} {
return ""
}
return $sel
}
# Begining of the actual tests
test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup {
deleteWindows
set x {}
} -body {
button .b -text Test
pack .b
bindtags .b .b
update
bind .b <Destroy> {
lappend x destroy
event generate .b <1>
event generate .b <ButtonRelease-1>
}
bind .b <1> {
lappend x button
}
destroy .b
return $x
} -cleanup {
deleteWindows
} -result {destroy}
test event-1.2 {event generate <Alt-z>} -setup {
deleteWindows
catch {unset ::event12result}
} -body {
set ::event12result 0
pack [entry .e]
update
bind .e <Alt-z> {set ::event12result "1"}
focus -force .e
event generate .e <Alt-z>
destroy .e
set ::event12result
} -cleanup {
deleteWindows
} -result 1
test event-2.1(keypress) {type into entry widget and hit Return} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
set return_binding 0
bind $e <Return> {set return_binding 1}
tkwait visibility $e
_keypress_string $e HELLO\n
list [$e get] $return_binding
} -cleanup {
deleteWindows
} -result {HELLO 1}
test event-2.2(keypress) {type into entry widget and then delete some text} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
tkwait visibility $e
_keypress_string $e MELLO
_keypress $e BackSpace
_keypress $e BackSpace
$e get
} -cleanup {
deleteWindows
} -result {MEL}
test event-2.3(keypress) {type into entry widget, triple click, hit Delete key,
and then type some more} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
tkwait visibility $e
_keypress_string $e JUMP
set result [$e get]
event generate $e <Enter>
for {set i 0} {$i < 3} {incr i} {
_pause 100
event generate $e <ButtonPress-1>
_pause 100
event generate $e <ButtonRelease-1>
}
_keypress $e Delete
_keypress_string $e UP
lappend result [$e get]
} -cleanup {
deleteWindows
} -result {JUMP UP}
test event-2.4(keypress) {type into text widget and hit Return} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
set return_binding 0
bind $e <Return> {set return_binding 1}
tkwait visibility $e
_keypress_string $e HELLO\n
list [$e get 1.0 end] $return_binding
} -cleanup {
deleteWindows
} -result [list "HELLO\n\n" 1]
test event-2.5(keypress) {type into text widget and then delete some text} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
tkwait visibility $e
_keypress_string $e MELLO
_keypress $e BackSpace
_keypress $e BackSpace
$e get 1.0 1.end
} -cleanup {
deleteWindows
} -result {MEL}
test event-2.6(keypress) {type into text widget, triple click,
hit Delete key, and then type some more} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
tkwait visibility $e
_keypress_string $e JUMP
set result [$e get 1.0 1.end]
event generate $e <Enter>
for {set i 0} {$i < 3} {incr i} {
_pause 100
event generate $e <ButtonPress-1>
_pause 100
event generate $e <ButtonRelease-1>
}
_keypress $e Delete
_keypress_string $e UP
lappend result [$e get 1.0 1.end]
} -cleanup {
deleteWindows
} -result {JUMP UP}
test event-3.1(click-drag) {click and drag in a text widget, this tests
tkTextSelectTo in text.tcl} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
tkwait visibility $e
_keypress_string $e "A Tcl/Tk selection test!"
set anchor 1.6
set selend 1.18
set result [list]
lappend result [$e get 1.0 1.end]
# Get the x,y coords of the second T in "Tcl/Tk"
foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
# Click down to set the insert cursor position
event generate $e <Enter>
event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
# Save the position of the insert cursor
lappend result [$e index insert]
# Now drag until selend is highlighted, then click up
set current $anchor
while {[$e compare $current <= $selend]} {
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
set current [$e index [list $current + 1 char]]
_pause 50
}
event generate $e <ButtonRelease-1> -x $current_x -y $current_y
_pause 200
# Save the position of the insert cursor
lappend result [$e index insert]
# Save the highlighted text
lappend result [_get_selection $e]
# Now click and click and drag to the left, over "Tcl/Tk selection"
event generate $e <ButtonPress-1> -x $current_x -y $current_y
while {[$e compare $current >= [list $anchor - 4 char]]} {
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
set current [$e index [list $current - 1 char]]
_pause 50
}
event generate $e <ButtonRelease-1> -x $current_x -y $current_y
_pause 200
# Save the position of the insert cursor
lappend result [$e index insert]
# Save the highlighted text
lappend result [_get_selection $e]
} -cleanup {
deleteWindows
} -result {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}}
test event-3.2(click-drag) {click and drag in an entry widget, this
tests tkEntryMouseSelect in entry.tcl} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
tkwait visibility $e
_keypress_string $e "A Tcl/Tk selection!"
set anchor 6
set selend 18
set result [list]
lappend result [$e get]
# Get the x,y coords of the second T in "Tcl/Tk"
foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
# Click down to set the insert cursor position
event generate $e <Enter>
event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
# Save the position of the insert cursor
lappend result [$e index insert]
# Now drag until selend is highlighted, then click up
set current $anchor
while {$current <= $selend} {
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
incr current
_pause 50
}
event generate $e <ButtonRelease-1> -x $current_x -y $current_y
_pause 200
# Save the position of the insert cursor
lappend result [$e index insert]
# Save the highlighted text
lappend result [_get_selection $e]
# Now click and click and drag to the left, over "Tcl/Tk selection"
event generate $e <ButtonPress-1> -x $current_x -y $current_y
while {$current >= ($anchor - 4)} {
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
incr current -1
_pause 50
}
event generate $e <ButtonRelease-1> -x $current_x -y $current_y
_pause 200
# Save the position of the insert cursor
lappend result [$e index insert]
# Save the highlighted text
lappend result [_get_selection $e]
} -cleanup {
deleteWindows
} -result {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}}
test event-4.1(double-click-drag) {click down, click up, click down again,
then drag in a text widget} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
tkwait visibility $e
_keypress_string $e "Word select test"
set anchor 1.8
# Get the x,y coords of the second e in "select"
foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
# Click down, release, then click down again
event generate $e <Enter>
event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
_pause 50
event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
_pause 50
event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
_pause 50
# Save the highlighted text
set result [list]
lappend result [_get_selection $e]
# Insert cursor should be at beginning of "select"
lappend result [$e index insert]
# Move mouse one character to the left
set current [$e index [list $anchor - 1 char]]
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
_pause 50
# Insert cursor should be before the l in "select"
lappend result [$e index insert]
# Selection should still be the word "select"
lappend result [_get_selection $e]
# Move mouse to the space before the word "select"
set current [$e index [list $current - 3 char]]
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
_pause 200
lappend result [$e index insert]
lappend result [_get_selection $e]
# Move mouse to the r in "Word"
set current 1.2
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
_pause 50
# Selection should now be "Word select"
lappend result [_get_selection $e]
# Insert cursor should be before the r in "Word"
lappend result [$e index insert]
return $result
} -cleanup {
deleteWindows
} -result {select 1.5 1.7 select 1.4 { select} {Word select} 1.2}
test event-4.2(double-click-drag) {click down, click up, click down again,
then drag in an entry widget} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
tkwait visibility $e
_keypress_string $e "Word select test"
set anchor 8
# Get the x,y coords of the second e in "select"
foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
# Click down, release, then click down again
event generate $e <Enter>
event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
_pause 50
event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
_pause 50
event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
_pause 50
set result [list]
lappend result [_get_selection $e]
# Insert cursor should be at the end of "select"
lappend result [$e index insert]
# Move mouse one character to the left
set current [expr {$anchor - 1}]
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
_pause 50
# Insert cursor should be before the l in "select"
lappend result [$e index insert]
# Selection should still be the word "select"
lappend result [_get_selection $e]
# Move mouse to the space before the word "select"
set current [expr {$current - 3}]
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
_pause 50
lappend result [$e index insert]
lappend result [_get_selection $e]
# Move mouse to the r in "Word"
set current [expr {$current - 2}]
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
_pause 50
# Selection should now be "Word select"
lappend result [_get_selection $e]
# Insert cursor should be before the r in "Word"
lappend result [$e index insert]
return $result
} -cleanup {
deleteWindows
} -result {select 11 7 select 4 { select} {Word select} 2}
test event-5.1(triple-click-drag) {Triple click and drag across lines in a
text widget, this should extend the selection to the new line} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
tkwait visibility $e
_keypress_string $e "LINE ONE\nLINE TWO\nLINE THREE"
set anchor 3.2
# Triple click one third line leaving mouse down
foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
event generate $e <Enter>
event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
_pause 50
event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
_pause 50
event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
_pause 50
event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
_pause 50
event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
_pause 50
set result [list]
lappend result [_get_selection $e]
# Drag up to second line
set current [$e index [list $anchor - 1 line]]
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
_pause 50
lappend result [_get_selection $e]
# Drag up to first line
set current [$e index [list $current - 1 line]]
foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
event generate $e <B1-Motion> -x $current_x -y $current_y
_pause 50
lappend result [_get_selection $e]
return $result
} -cleanup {
deleteWindows
} -result [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \
"LINE ONE\nLINE TWO\nLINE THREE\n"]
test event-6.1(button-state) {button press in a window that is then
destroyed, when the mouse is moved into another window it
should not generate a <B1-motion> event since the mouse
was not pressed down in that window} -setup {
deleteWindows
} -body {
set t [toplevel .t]
event generate $t <ButtonPress-1>
destroy $t
set t [toplevel .t]
set motion nomotion
bind $t <B1-Motion> {set motion inmotion}
event generate $t <Motion>
return $motion
} -cleanup {
deleteWindows
} -result {nomotion}
test event-7.1(double-click) {A double click on a lone character
in a text widget should select that character} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
tkwait visibility $e
focus -force $e
_keypress_string $e "On A letter"
set anchor 1.3
# Get x,y coords just inside the left
# and right hand side of the letter A
foreach {x1 y1 width height} [$e bbox $anchor] break
set middle_y [expr {$y1 + ($height / 2)}]
set left_x [expr {$x1 + 2}]
set left_y $middle_y
set right_x [expr {($x1 + $width) - 2}]
set right_y $middle_y
# Double click near left hand egde of the letter A
event generate $e <Enter>
event generate $e <ButtonPress-1> -x $left_x -y $left_y
_pause 50
event generate $e <ButtonRelease-1> -x $left_x -y $left_y
_pause 50
event generate $e <ButtonPress-1> -x $left_x -y $left_y
_pause 50
event generate $e <ButtonRelease-1> -x $left_x -y $left_y
_pause 50
set result [list]
lappend result [$e index insert]
lappend result [_get_selection $e]
# Clear selection by clicking at 0,0
event generate $e <ButtonPress-1> -x 0 -y 0
_pause 50
event generate $e <ButtonRelease-1> -x 0 -y 0
_pause 50
# Double click near right hand edge of the letter A
event generate $e <ButtonPress-1> -x $right_x -y $right_y
_pause 50
event generate $e <ButtonRelease-1> -x $right_x -y $right_y
_pause 50
event generate $e <ButtonPress-1> -x $right_x -y $right_y
_pause 50
event generate $e <ButtonRelease-1> -x $right_x -y $right_y
_pause 50
lappend result [$e index insert]
lappend result [_get_selection $e]
return $result
} -cleanup {
deleteWindows
} -result {1.3 A 1.3 A}
test event-7.2(double-click) {A double click on a lone character
in an entry widget should select that character} -setup {
deleteWindows
} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
tkwait visibility $e
focus -force $e
_keypress_string $e "On A letter"
set anchor 3
# Get x,y coords just inside the left
# and right hand side of the letter A
foreach {x1 y1 width height} [$e bbox $anchor] break
set middle_y [expr {$y1 + ($height / 2)}]
set left_x [expr {$x1 + 2}]
set left_y $middle_y
set right_x [expr {($x1 + $width) - 2}]
set right_y $middle_y
# Double click near left hand egde of the letter A
event generate $e <Enter>
event generate $e <ButtonPress-1> -x $left_x -y $left_y
_pause 50
event generate $e <ButtonRelease-1> -x $left_x -y $left_y
_pause 50
event generate $e <ButtonPress-1> -x $left_x -y $left_y
_pause 50
event generate $e <ButtonRelease-1> -x $left_x -y $left_y
_pause 50
set result [list]
lappend result [$e index insert]
lappend result [_get_selection $e]
# Clear selection by clicking at 0,0
event generate $e <ButtonPress-1> -x 0 -y 0
_pause 50
event generate $e <ButtonRelease-1> -x 0 -y 0
_pause 50
# Double click near right hand edge of the letter A
event generate $e <ButtonPress-1> -x $right_x -y $right_y
_pause 50
event generate $e <ButtonRelease-1> -x $right_x -y $right_y
_pause 50
event generate $e <ButtonPress-1> -x $right_x -y $right_y
_pause 50
event generate $e <ButtonRelease-1> -x $right_x -y $right_y
_pause 50
lappend result [$e index insert]
lappend result [_get_selection $e]
return $result
} -cleanup {
deleteWindows
} -result {4 A 4 A}
# cleanup
unset -nocomplain keypress_lookup
rename _init_keypress_lookup {}
rename _keypress_lookup {}
rename _keypress {}
rename _pause {}
rename _text_ind_to_x_y {}
rename _get_selection {}
cleanupTests
return

173
tests/face.xbm Normal file
View File

@@ -0,0 +1,173 @@
#define face_width 108
#define face_height 144
#define face_x_hot 48
#define face_y_hot 80
static char face_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08, 0x09,
0x20, 0x80, 0x24, 0x05, 0x00, 0x80, 0x08, 0x00, 0x00, 0x00, 0x00, 0x88,
0x24, 0x20, 0x80, 0x24, 0x00, 0x00, 0x00, 0x10, 0x80, 0x04, 0x00, 0x01,
0x00, 0x01, 0x40, 0x0a, 0x09, 0x00, 0x92, 0x04, 0x80, 0x00, 0x00, 0x00,
0x00, 0x00, 0x10, 0x40, 0x12, 0x00, 0x00, 0x10, 0x40, 0x00, 0x00, 0x84,
0x24, 0x40, 0x22, 0xa8, 0x02, 0x14, 0x84, 0x92, 0x40, 0x42, 0x12, 0x04,
0x10, 0x00, 0x00, 0x00, 0x00, 0x52, 0x00, 0x52, 0x11, 0x00, 0x12, 0x00,
0x40, 0x02, 0x00, 0x20, 0x00, 0x08, 0x00, 0xaa, 0x02, 0x54, 0x85, 0x24,
0x00, 0x10, 0x12, 0x00, 0x00, 0x81, 0x44, 0x00, 0x90, 0x5a, 0x00, 0xea,
0x1b, 0x00, 0x80, 0x40, 0x40, 0x02, 0x00, 0x08, 0x00, 0x20, 0xa2, 0x05,
0x8a, 0xb4, 0x6e, 0x45, 0x12, 0x04, 0x08, 0x00, 0x00, 0x00, 0x10, 0x02,
0xa8, 0x92, 0x00, 0xda, 0x5f, 0x10, 0x00, 0x10, 0xa1, 0x04, 0x20, 0x41,
0x02, 0x00, 0x5a, 0x25, 0xa0, 0xff, 0xfb, 0x05, 0x41, 0x02, 0x04, 0x00,
0x00, 0x08, 0x40, 0x80, 0xec, 0x9b, 0xec, 0xfe, 0x7f, 0x01, 0x04, 0x20,
0x90, 0x02, 0x04, 0x00, 0x08, 0x20, 0xfb, 0x2e, 0xf5, 0xff, 0xff, 0x57,
0x00, 0x04, 0x02, 0x00, 0x00, 0x20, 0x01, 0xc1, 0x6e, 0xab, 0xfa, 0xff,
0xff, 0x05, 0x90, 0x20, 0x48, 0x02, 0x00, 0x04, 0x20, 0xa8, 0xdf, 0xb5,
0xfe, 0xff, 0xff, 0x0b, 0x01, 0x00, 0x01, 0x00, 0x80, 0x80, 0x04, 0xe0,
0xbb, 0xef, 0xff, 0xff, 0x7f, 0x01, 0x00, 0x04, 0x48, 0x02, 0x00, 0x20,
0x80, 0xf4, 0x6f, 0xfb, 0xff, 0xff, 0xff, 0x20, 0x90, 0x40, 0x02, 0x00,
0x00, 0x04, 0x08, 0xb8, 0xf6, 0xff, 0xff, 0xdf, 0xbe, 0x12, 0x45, 0x10,
0x90, 0x04, 0x90, 0x00, 0x22, 0xfa, 0xff, 0xff, 0xff, 0xbb, 0xd7, 0xe9,
0x3a, 0x02, 0x02, 0x00, 0x04, 0x90, 0x80, 0xfe, 0xdf, 0xf6, 0xb7, 0xef,
0xbe, 0x56, 0x57, 0x40, 0x48, 0x09, 0x00, 0x04, 0x00, 0xfa, 0xf5, 0xdf,
0xed, 0x5a, 0xd5, 0xea, 0xbd, 0x09, 0x00, 0x00, 0x40, 0x00, 0x92, 0xfe,
0xbf, 0x7d, 0xb7, 0x6a, 0x55, 0xbf, 0xf7, 0x02, 0x11, 0x01, 0x00, 0x91,
0x00, 0xff, 0xff, 0xaf, 0x55, 0x55, 0x5b, 0xeb, 0xef, 0x22, 0x04, 0x04,
0x04, 0x00, 0xa4, 0xff, 0xf7, 0xad, 0xaa, 0xaa, 0xaa, 0xbe, 0xfe, 0x03,
0x20, 0x00, 0x10, 0x44, 0x80, 0xff, 0x7f, 0x55, 0x12, 0x91, 0x2a, 0xeb,
0xbf, 0x0b, 0x82, 0x02, 0x00, 0x00, 0xd1, 0x7f, 0xdf, 0xa2, 0xa4, 0x54,
0x55, 0xfd, 0xfd, 0x47, 0x08, 0x08, 0x00, 0x21, 0xe4, 0xff, 0x37, 0x11,
0x09, 0xa5, 0xaa, 0xb6, 0xff, 0x0d, 0x80, 0x00, 0x00, 0x04, 0xd0, 0xff,
0x4f, 0x44, 0x20, 0x48, 0x55, 0xfb, 0xff, 0x27, 0x11, 0x02, 0x40, 0x40,
0xe2, 0xfb, 0x15, 0x11, 0x4a, 0x55, 0x4a, 0x7d, 0xf7, 0x0f, 0x00, 0x00,
0x04, 0x08, 0xf8, 0xdf, 0x52, 0x44, 0x01, 0x52, 0xb5, 0xfa, 0xff, 0x0f,
0x49, 0x02, 0x00, 0x02, 0xe9, 0xf6, 0x0a, 0x11, 0xa4, 0x88, 0x4a, 0x6d,
0xff, 0x5f, 0x00, 0x00, 0x10, 0x20, 0xf0, 0x2f, 0x21, 0x44, 0x10, 0x52,
0xb5, 0xfa, 0xff, 0x0f, 0x44, 0x04, 0x80, 0x08, 0xf8, 0xab, 0x8a, 0x00,
0x81, 0xa4, 0xd4, 0xd6, 0xfe, 0x2f, 0x00, 0x00, 0x04, 0x40, 0xb5, 0x2d,
0x21, 0x08, 0x04, 0x90, 0xaa, 0xfa, 0xff, 0x1f, 0x11, 0x01, 0x00, 0x04,
0xf0, 0x57, 0x0a, 0x22, 0x40, 0x4a, 0xda, 0x5e, 0xfb, 0x1f, 0x40, 0x00,
0x40, 0x20, 0xba, 0x95, 0x90, 0x00, 0x01, 0xa0, 0xaa, 0xea, 0xff, 0x5f,
0x02, 0x02, 0x00, 0x01, 0xe8, 0x57, 0x05, 0x00, 0x00, 0x12, 0xd5, 0xfe,
0xfd, 0x1f, 0x48, 0x00, 0x04, 0x48, 0x7a, 0x95, 0x08, 0x02, 0x10, 0x40,
0xaa, 0x55, 0xf7, 0x1f, 0x00, 0x09, 0x20, 0x00, 0xf8, 0x57, 0x22, 0x10,
0x00, 0x28, 0xa9, 0xfa, 0xff, 0x5f, 0x02, 0x00, 0x00, 0x49, 0xdd, 0x29,
0x01, 0x00, 0x80, 0x80, 0xaa, 0xd7, 0xff, 0x0f, 0x10, 0x00, 0x08, 0x00,
0xf8, 0x96, 0x08, 0x00, 0x00, 0x20, 0x54, 0xfa, 0xee, 0x3f, 0x81, 0x04,
0x40, 0x24, 0xfe, 0x55, 0x82, 0x00, 0x00, 0x82, 0xd2, 0xad, 0xff, 0x0f,
0x08, 0x00, 0x04, 0x80, 0x6c, 0x97, 0x00, 0x00, 0x02, 0x20, 0xa9, 0xf6,
0xdf, 0x5f, 0x00, 0x02, 0x20, 0x09, 0xfa, 0x49, 0x12, 0x00, 0x20, 0x84,
0x54, 0xdb, 0xfe, 0x1f, 0x91, 0x00, 0x00, 0x00, 0xf8, 0x2b, 0x00, 0x20,
0x00, 0x40, 0xa4, 0xf6, 0xbb, 0x1f, 0x04, 0x00, 0x44, 0x92, 0x7e, 0x95,
0x02, 0x00, 0x00, 0x89, 0xaa, 0xdd, 0xff, 0x1f, 0x20, 0x09, 0x10, 0x00,
0xf4, 0x57, 0x20, 0x01, 0x08, 0x20, 0xa9, 0x76, 0xff, 0x5f, 0x02, 0x00,
0x00, 0x21, 0xfc, 0x4a, 0x05, 0x00, 0x01, 0x80, 0x54, 0xdb, 0xff, 0x1e,
0x08, 0x02, 0x04, 0x08, 0xf9, 0x2b, 0x00, 0x00, 0x40, 0x28, 0xd2, 0xf6,
0xff, 0xbf, 0x80, 0x00, 0x90, 0x00, 0xbc, 0x92, 0x08, 0x10, 0x00, 0x82,
0x54, 0xdb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x44, 0xf9, 0x55, 0x02, 0x01,
0x00, 0x20, 0xaa, 0xbd, 0xfd, 0x3f, 0x08, 0x04, 0x04, 0x10, 0xf4, 0x2a,
0x01, 0x00, 0x22, 0x80, 0xd4, 0xf6, 0xff, 0x5f, 0x82, 0x00, 0x40, 0x02,
0xf8, 0x55, 0x20, 0x00, 0x00, 0x50, 0x6a, 0xdf, 0xfe, 0x3f, 0x00, 0x00,
0x00, 0x48, 0xe9, 0x4a, 0x05, 0x08, 0x00, 0xa5, 0xd5, 0xf5, 0xff, 0x3f,
0x10, 0x01, 0x10, 0x01, 0xb0, 0xab, 0x92, 0x02, 0x40, 0xf8, 0xbf, 0xde,
0xfe, 0x5f, 0x02, 0x04, 0x04, 0x48, 0xfa, 0xd4, 0x6f, 0x20, 0x84, 0xef,
0xff, 0xfb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x00, 0xe0, 0xed, 0xbf, 0x0b,
0xa1, 0x7e, 0xff, 0xbf, 0xfd, 0x5f, 0x04, 0x01, 0x20, 0x49, 0xd2, 0xfb,
0xfe, 0x55, 0xd4, 0xff, 0xff, 0xf6, 0xff, 0x07, 0x00, 0x04, 0x00, 0x00,
0xc0, 0xaa, 0xfb, 0x2b, 0xa2, 0xfe, 0xff, 0xdf, 0xee, 0x1f, 0x91, 0x00,
0x82, 0xa4, 0xa4, 0xf5, 0xff, 0x57, 0xd5, 0xff, 0xbf, 0xfd, 0xff, 0x4d,
0x00, 0x00, 0x20, 0x00, 0x88, 0x5b, 0xff, 0x2f, 0x69, 0xff, 0xff, 0xdb,
0xfe, 0x1f, 0x24, 0x02, 0x00, 0x49, 0xa2, 0xd6, 0xff, 0x5f, 0xea, 0xff,
0x7f, 0x7f, 0x7f, 0x0d, 0x00, 0x00, 0x10, 0x00, 0x40, 0xab, 0xf7, 0xbb,
0xf0, 0xdf, 0xff, 0xd5, 0xff, 0xbf, 0x82, 0x04, 0x42, 0x24, 0x91, 0xd5,
0xaa, 0xae, 0xd4, 0xaa, 0x52, 0x7b, 0xff, 0x15, 0x08, 0x00, 0x00, 0x01,
0x04, 0x55, 0xd5, 0x55, 0x70, 0x5b, 0x75, 0xdd, 0xdf, 0x1f, 0x40, 0x00,
0x08, 0x48, 0xa0, 0x4a, 0xa9, 0x56, 0xea, 0x56, 0xad, 0x6a, 0x7d, 0x9b,
0x04, 0x01, 0x00, 0x02, 0x42, 0x2a, 0xd5, 0xaa, 0xa8, 0xaa, 0xaa, 0xfa,
0xdf, 0x2f, 0x10, 0x04, 0x22, 0x48, 0x08, 0x45, 0x2a, 0x15, 0x68, 0x55,
0x55, 0xd7, 0x76, 0x1b, 0x00, 0x00, 0x00, 0x01, 0x40, 0x2a, 0x80, 0xa0,
0xb2, 0x09, 0x48, 0xb9, 0xdf, 0x17, 0x22, 0x01, 0x00, 0x24, 0x45, 0x8a,
0x24, 0x4a, 0x54, 0x51, 0x91, 0xf6, 0x6e, 0x4b, 0x00, 0x04, 0x90, 0x00,
0x80, 0x52, 0x00, 0x20, 0x69, 0x05, 0xa4, 0xaa, 0xff, 0x1e, 0x48, 0x00,
0x02, 0x92, 0x08, 0x05, 0x81, 0x94, 0xd4, 0x92, 0x40, 0xfd, 0xb6, 0x8b,
0x00, 0x01, 0x40, 0x00, 0x82, 0x54, 0x00, 0x48, 0x68, 0x05, 0x90, 0xa4,
0xef, 0x06, 0x24, 0x00, 0x08, 0x12, 0x10, 0x05, 0x00, 0x10, 0xb5, 0x01,
0x42, 0xfb, 0xbf, 0x43, 0x00, 0x09, 0x00, 0x40, 0x81, 0xa8, 0x08, 0x4a,
0xaa, 0x96, 0x90, 0xac, 0x6d, 0x15, 0x22, 0x00, 0x20, 0x09, 0x04, 0x15,
0x80, 0x28, 0xdc, 0x01, 0x24, 0xfb, 0xbf, 0x01, 0x80, 0x04, 0x09, 0x00,
0x40, 0x48, 0x02, 0x45, 0xb2, 0x2e, 0x41, 0x6d, 0xef, 0x05, 0x11, 0x00,
0x40, 0x52, 0x02, 0x15, 0x29, 0x2a, 0xac, 0x42, 0x54, 0xfb, 0x3b, 0x51,
0x84, 0x00, 0x08, 0x00, 0x20, 0x54, 0x80, 0x05, 0xb5, 0x3d, 0xa2, 0xb6,
0xdf, 0x00, 0x20, 0x04, 0x20, 0x49, 0x89, 0xa8, 0x6a, 0x29, 0xac, 0xd6,
0x54, 0xff, 0x3f, 0x84, 0x00, 0x01, 0x04, 0x10, 0x00, 0x94, 0xa8, 0x56,
0xda, 0x5f, 0xab, 0xd5, 0x1e, 0x10, 0x48, 0x00, 0x90, 0x82, 0x48, 0xa8,
0xb2, 0xac, 0xfd, 0x55, 0xd5, 0xfe, 0x9f, 0x80, 0x00, 0x0a, 0x02, 0x08,
0x02, 0x55, 0x5a, 0x75, 0xff, 0xaf, 0xb6, 0xf7, 0x2d, 0x12, 0x92, 0x00,
0x10, 0x20, 0x10, 0xa8, 0x54, 0xd5, 0xbf, 0x5d, 0xad, 0xdd, 0x0f, 0x00,
0x00, 0x04, 0x40, 0x09, 0x84, 0xa8, 0xaa, 0x5a, 0xed, 0xeb, 0x6a, 0xff,
0x9f, 0xa4, 0x24, 0x01, 0x02, 0xa0, 0x20, 0x50, 0x55, 0xd5, 0xbe, 0xae,
0xad, 0xfd, 0x16, 0x00, 0x10, 0x04, 0x20, 0x0a, 0x08, 0xb4, 0xaa, 0x95,
0xaa, 0x7b, 0xb7, 0xdb, 0x5f, 0x92, 0x04, 0x01, 0x84, 0x20, 0x21, 0x51,
0xd5, 0x2a, 0xa9, 0xee, 0xd5, 0xfe, 0x0d, 0x00, 0x20, 0x04, 0x10, 0x00,
0x08, 0x50, 0xe9, 0xd7, 0xd4, 0xfb, 0xb5, 0xff, 0x9f, 0x24, 0x09, 0x01,
0x42, 0x4a, 0xa2, 0x64, 0xd5, 0x55, 0x7b, 0x7f, 0xda, 0x7d, 0x4f, 0x00,
0x20, 0x04, 0x00, 0x80, 0x00, 0xa0, 0x2a, 0x13, 0x84, 0x6a, 0x55, 0xff,
0x1d, 0x48, 0x8a, 0x00, 0x94, 0x24, 0x8a, 0xc8, 0xaa, 0x42, 0x20, 0x5d,
0xf5, 0xff, 0x5f, 0x01, 0x00, 0x02, 0x01, 0x00, 0x20, 0xa2, 0x4a, 0x1a,
0x82, 0x56, 0xda, 0xbd, 0x3f, 0x92, 0x92, 0x00, 0x90, 0x92, 0x00, 0x40,
0x95, 0x6a, 0xf4, 0x55, 0x6d, 0xff, 0xd6, 0x00, 0x00, 0x0a, 0x04, 0x20,
0x14, 0x49, 0x4b, 0xaa, 0xaa, 0x56, 0xf5, 0xff, 0xbf, 0xab, 0xa4, 0x00,
0x20, 0x89, 0x40, 0x80, 0xaa, 0xaa, 0xaa, 0xaa, 0xde, 0xbf, 0xeb, 0x03,
0x00, 0x02, 0x04, 0x02, 0x0a, 0x10, 0x2b, 0x2a, 0x55, 0x5b, 0xf5, 0xff,
0xd7, 0x2f, 0x92, 0x00, 0x10, 0x28, 0x21, 0x01, 0x56, 0x95, 0xa0, 0x56,
0xdf, 0xef, 0xea, 0x87, 0x40, 0x0a, 0x42, 0x41, 0x00, 0x90, 0xaa, 0x52,
0xb6, 0xad, 0xfa, 0xff, 0xd5, 0x2f, 0x14, 0x00, 0x00, 0x04, 0x95, 0x04,
0xaa, 0xac, 0x55, 0x6b, 0xff, 0xb7, 0xea, 0x9f, 0x40, 0x02, 0x28, 0x51,
0x00, 0x40, 0x58, 0xd5, 0xda, 0xd6, 0x6e, 0x7f, 0xf9, 0x3f, 0x12, 0x04,
0x02, 0x04, 0x49, 0x25, 0x55, 0xaa, 0x77, 0xab, 0xff, 0x2b, 0xfd, 0x3f,
0x48, 0x01, 0x20, 0x41, 0x00, 0x00, 0x58, 0xa9, 0xda, 0xea, 0xfd, 0xaf,
0xfa, 0xff, 0x02, 0x04, 0x08, 0x14, 0x29, 0x49, 0x52, 0x55, 0x55, 0x55,
0xff, 0x8d, 0xfe, 0x3f, 0xa8, 0x00, 0x02, 0x41, 0x00, 0x02, 0xa0, 0xa2,
0xaa, 0xea, 0xff, 0x53, 0xfd, 0xff, 0x02, 0x04, 0x50, 0x04, 0x25, 0xa8,
0x54, 0x49, 0x52, 0xb5, 0xbf, 0x8a, 0xfe, 0xff, 0xa9, 0x08, 0x04, 0x50,
0x80, 0x02, 0xa1, 0x2a, 0x95, 0xea, 0xff, 0xa1, 0xff, 0xff, 0x03, 0x02,
0x90, 0x02, 0x09, 0x08, 0x44, 0x49, 0x52, 0xbd, 0x7f, 0xca, 0xff, 0xff,
0x2b, 0x09, 0x04, 0x48, 0x40, 0x82, 0x90, 0x56, 0xa9, 0xf6, 0xbf, 0xd0,
0xff, 0xff, 0x47, 0x00, 0x50, 0x02, 0x15, 0x11, 0x40, 0x95, 0xaa, 0xfd,
0x2f, 0xe9, 0xff, 0xff, 0x8f, 0x0a, 0x84, 0x50, 0x40, 0x84, 0x14, 0xaa,
0x6a, 0xff, 0x5f, 0xf2, 0xff, 0xff, 0x7f, 0x00, 0x10, 0x02, 0x09, 0x10,
0x40, 0x7d, 0xf7, 0xff, 0x0b, 0xfc, 0xff, 0xff, 0xaf, 0x02, 0x84, 0x50,
0x42, 0x85, 0x12, 0xd0, 0xdd, 0xff, 0xa7, 0xf2, 0xff, 0xff, 0xff, 0x04,
0x00, 0x0a, 0x08, 0x10, 0x48, 0xf8, 0xff, 0xff, 0x0a, 0xfe, 0xff, 0xff,
0x7f, 0x03, 0xa4, 0x80, 0xa2, 0x8a, 0x02, 0x68, 0xff, 0xff, 0x52, 0xfd,
0xff, 0xff, 0xff, 0x07, 0x00, 0x2a, 0x08, 0x20, 0x28, 0xdc, 0xff, 0x5f,
0x05, 0xff, 0xff, 0xff, 0xff, 0x0d, 0x92, 0x40, 0x22, 0x09, 0x02, 0xea,
0xfb, 0xaf, 0x48, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x12, 0x81, 0xa0,
0x48, 0x9c, 0x6e, 0x93, 0xa2, 0xff, 0xff, 0xff, 0xff, 0x07, 0xa8, 0x40,
0x28, 0x0a, 0x02, 0x74, 0xb5, 0x45, 0x81, 0xff, 0xff, 0xff, 0xff, 0x0f,
0x02, 0x0a, 0x81, 0x20, 0x08, 0xae, 0xaa, 0x90, 0xe8, 0xff, 0xff, 0xff,
0xff, 0x0f, 0x90, 0x40, 0x28, 0x88, 0x12, 0x58, 0x15, 0x50, 0xd0, 0xff,
0xff, 0xff, 0xff, 0x0f, 0x44, 0x0a, 0x41, 0x21, 0x08, 0xae, 0x04, 0x14,
0xf0, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40, 0x14, 0x88, 0x04, 0xba,
0x02, 0x28, 0xe8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x42, 0x15, 0x41, 0x21,
0x05, 0xad, 0x00, 0x05, 0xf8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40,
0x24, 0x8a, 0x0e, 0x36, 0x00, 0x0a, 0xf4, 0xff, 0xff, 0xff, 0xff, 0x0f,
0x42, 0x25, 0x90, 0xd0, 0x8b, 0xc2, 0x41, 0x05, 0xfc, 0xff, 0xff, 0xff,
0xff, 0x0f, 0x10, 0x08, 0x05, 0xe8, 0x8e, 0x58, 0x80, 0x02, 0xfa, 0xff,
0xff, 0xff, 0xff, 0x0f, 0x4a, 0x20, 0xa8, 0xba, 0x0b, 0x2b, 0x51, 0x01,
0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x8a, 0x02, 0xe8, 0xaf, 0x84,
0x90, 0x04, 0xfd, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x52, 0x21, 0x54, 0xbf,
0x1f, 0x15, 0xa5, 0x02, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x08,
0x01, 0xfa, 0xb6, 0xa4, 0x52, 0x40, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f,
0x4a, 0xa2, 0x54, 0xef, 0x5f, 0x4b, 0xa4, 0x80, 0xff, 0xff, 0xff, 0xff,
0xff, 0x0f, 0x80, 0x10, 0x82, 0xfe, 0xbf, 0x92, 0x52, 0x42, 0xff, 0xff,
0xff, 0xff, 0xff, 0x0f, 0x12, 0x42, 0xa8, 0xbf, 0x1f, 0x24, 0x80, 0xa0,
0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28, 0x8a, 0xf7, 0x37, 0x80,
0x52, 0x80, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x82, 0xe0, 0xff,
0x1f, 0x00, 0x20, 0xe1, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28,
0xca, 0xff, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f,
0x10, 0x42, 0xf0, 0xfd, 0x1b, 0x00, 0x50, 0xf0, 0xff, 0xff, 0xff, 0xff,
0xff, 0x0f, 0xa4, 0x10, 0xc5, 0xff, 0x1f, 0x00, 0x00, 0xe0, 0xff, 0xff,
0xff, 0xff, 0xff, 0x0f, 0x00, 0x22, 0xf8, 0xff, 0x0e, 0x00, 0x00, 0xf0,
0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xaa, 0x88, 0xe2, 0xff, 0x0f, 0x10,
0x00, 0xf0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x25, 0xfa, 0xff,
0x0f, 0x01, 0x11, 0xfd, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xff, 0xfb,
0xfb, 0xff, 0x7f, 0x5d, 0xd5, 0xfa, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f};

476
tests/filebox.test Normal file
View File

@@ -0,0 +1,476 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} {
# MacOS type that is too long
set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg]
regsub -all "\0" $res {\\0}
} {1 {bad Macintosh file type "\0\0\0\0\0"}}
test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} {
# MacOS type that is too short, but looks ok in utf (4 bytes).
set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg]
regsub -all "\0" $msg {\\0} msg
list $x $msg
} {1 {bad Macintosh file type "\0\0"}}
set tk_strictMotif_old $tk_strictMotif
#----------------------------------------------------------------------
#
# 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
if {$parent == "."} {
set w .__tk_filedialog
} else {
set w $parent.__tk_filedialog
}
upvar ::tk::dialog::file::__tk_filedialog 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
if {$parent == "."} {
set w .__tk_filedialog
} else {
set w $parent.__tk_filedialog
}
upvar ::tk::dialog::file::__tk_filedialog 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 {$tcl_platform(platform) == "unix"} {
set modes "0 1"
} else {
set modes 1
}
set unknownOptionsMsg(tk_getOpenFile) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
set unknownOptionsMsg(tk_getSaveFile) {bad option "-foo": must be -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable}
set tmpFile "filebox.tmp"
makeFile {
# this file can be empty!
} $tmpFile
array set filters {
1 {}
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" *}
}
3 {
{"Text files" {.txt .doc} TEXT}
{"Foo" {""} TEXT}
}
}
foreach mode $modes {
#
# Test both the motif version and the "tk" version of the file dialog
# box on Unix.
#
# Note that this means that test names are unusually complex.
#
set addedExtensions {}
if {$tcl_platform(platform) == "unix"} {
set tk_strictMotif $mode
# Extension adding is only done when using the non-motif file
# box with an extension-less filename
if {!$mode} {
set addedExtensions {NONE {} .txt .txt}
}
}
test filebox-1.1-$mode "tk_getOpenFile command" -body {
tk_getOpenFile -foo
} -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
catch {tk_getOpenFile -foo 1} msg
regsub -all , $msg "" options
regsub \"-foo\" $options "" options
foreach option $options {
if {[string index $option 0] eq "-"} {
test filebox-1.2-$mode$option "tk_getOpenFile command" -body {
tk_getOpenFile $option
} -returnCodes error -result "value for \"$option\" missing"
}
}
test filebox-1.3-$mode "tk_getOpenFile command" -body {
tk_getOpenFile -foo bar
} -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
test filebox-1.4-$mode "tk_getOpenFile command" -body {
tk_getOpenFile -initialdir
} -returnCodes error -result {value for "-initialdir" missing}
test filebox-1.5-$mode "tk_getOpenFile command" -body {
tk_getOpenFile -parent foo.bar
} -returnCodes error -result {bad window path name "foo.bar"}
test filebox-1.6-$mode "tk_getOpenFile command" -body {
tk_getOpenFile -filetypes {Foo}
} -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}
set isNative [expr {
[info commands ::tk::MotifFDialog] eq "" &&
[info commands ::tk::dialog::file::] eq ""
}]
set parent .
set verylongstring longstring:
set verylongstring $verylongstring$verylongstring
set verylongstring $verylongstring$verylongstring
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-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToPressButton $parent cancel
tk_getOpenFile -title "Press Cancel ($verylongstring)" -parent $parent
} ""
set fileName $tmpFile
set fileDir [tcltest::temporaryDirectory]
set pathName [file join $fileDir $fileName]
test filebox-2.2-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getOpenFile -title "Press Ok" \
-parent $parent -initialfile $fileName -initialdir $fileDir]
} $pathName
test filebox-2.3-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToEnterFileByKey $parent $fileName $fileDir
set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
-parent $parent -initialdir $fileDir]
} $pathName
test filebox-2.4-$mode "tk_getOpenFile command" nonUnixUserInteraction {
cd $fileDir
ToPressButton $parent ok
set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
-parent $parent -initialdir . -initialfile $fileName]
} $pathName
test filebox-2.5-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
-parent $parent -initialdir /badpath -initialfile $fileName]
} $pathName
test filebox-2.6-$mode "tk_getOpenFile command" -setup {
toplevel .t1; toplevel .t2
wm geometry .t1 +0+0
wm geometry .t2 +0+0
} -constraints nonUnixUserInteraction -body {
set choice {}
ToPressButton .t1 ok
lappend choice [tk_getOpenFile \
-title "Enter \"$fileName\" and press Ok" \
-parent .t1 -initialdir $fileDir \
-initialfile $fileName]
ToPressButton .t2 ok
lappend choice [tk_getOpenFile \
-title "Enter \"$fileName\" and press Ok" \
-parent .t2 -initialdir $fileDir \
-initialfile $fileName]
ToPressButton .t1 ok
lappend choice [tk_getOpenFile \
-title "Enter \"$fileName\" and press Ok" \
-parent .t1 -initialdir $fileDir \
-initialfile $fileName]
} -result [list $pathName $pathName $pathName] -cleanup {
destroy .t1
destroy .t2
}
foreach x [lsort -integer [array names filters]] {
test filebox-3.$x-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getOpenFile -title "Press Ok" \
-filetypes $filters($x) -parent $parent \
-initialfile $fileName -initialdir $fileDir]
} $pathName
}
foreach {x res} [list 1 "-unset-" 2 "Text files"] {
set t [expr {$x + [llength [array names filters]]}]
test filebox-3.$t-$mode "tk_getOpenFile command" nonUnixUserInteraction {
catch {unset tv}
catch {unset typeName}
ToPressButton $parent ok
if {[info exists tv]} {
} else {
}
set choice [tk_getOpenFile -title "Press Ok" \
-filetypes $filters($x) -parent $parent \
-initialfile $fileName -initialdir $fileDir \
-typevariable tv]
if {[info exists tv]} {
regexp {^(.*) \(.*\)$} $tv dummy typeName
} else {
set typeName "-unset-"
}
set typeName
} $res
}
test filebox-4.1-$mode "tk_getSaveFile command" -body {
tk_getSaveFile -foo
} -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
catch {tk_getSaveFile -foo 1} msg
regsub -all , $msg "" options
regsub \"-foo\" $options "" options
foreach option $options {
if {[string index $option 0] eq "-"} {
test filebox-4.2-$mode$option "tk_getSaveFile command" -body {
tk_getSaveFile $option
} -returnCodes error -result "value for \"$option\" missing"
}
}
test filebox-4.3-$mode "tk_getSaveFile command" -body {
tk_getSaveFile -foo bar
} -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
test filebox-4.4-$mode "tk_getSaveFile command" -body {
tk_getSaveFile -initialdir
} -returnCodes error -result {value for "-initialdir" missing}
test filebox-4.5-$mode "tk_getSaveFile command" -body {
tk_getSaveFile -parent foo.bar
} -returnCodes error -result {bad window path name "foo.bar"}
test filebox-4.6-$mode "tk_getSaveFile command" -body {
tk_getSaveFile -filetypes {Foo}
} -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}
set isNative [expr {
[info commands ::tk::MotifFDialog] eq "" &&
[info commands ::tk::dialog::file::] eq ""
}]
set parent .
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-5.1-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent cancel
tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent
} ""
set fileName "12x 455"
set fileDir [pwd]
set pathName [file join [pwd] $fileName]
test filebox-5.2-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getSaveFile -title "Press Ok" \
-parent $parent -initialfile $fileName -initialdir $fileDir]
} $pathName
test filebox-5.3-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToEnterFileByKey $parent $fileName $fileDir
set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
-parent $parent -initialdir $fileDir]
} $pathName
test filebox-5.4-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
-parent $parent -initialdir . -initialfile $fileName]
} $pathName
test filebox-5.5-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
-parent $parent -initialdir /badpath -initialfile $fileName]
} $pathName
test filebox-5.6-$mode "tk_getSaveFile command" -setup {
toplevel .t1; toplevel .t2
wm geometry .t1 +0+0
wm geometry .t2 +0+0
} -constraints nonUnixUserInteraction -body {
set choice {}
ToPressButton .t1 ok
lappend choice [tk_getSaveFile \
-title "Enter \"$fileName\" and press Ok" \
-parent .t1 -initialdir $fileDir -initialfile $fileName]
ToPressButton .t2 ok
lappend choice [tk_getSaveFile \
-title "Enter \"$fileName\" and press Ok" \
-parent .t2 -initialdir $fileDir -initialfile $fileName]
ToPressButton .t1 ok
lappend choice [tk_getSaveFile \
-title "Enter \"$fileName\" and press Ok" \
-parent .t1 -initialdir $fileDir -initialfile $fileName]
} -result [list $pathName $pathName $pathName] -cleanup {
destroy .t1
destroy .t2
}
foreach x [lsort -integer [array names filters]] {
test filebox-6.$x-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getSaveFile -title "Press Ok" \
-filetypes $filters($x) -parent $parent \
-initialfile $fileName -initialdir $fileDir]
} $pathName[lindex $addedExtensions $x]
}
if {!$mode} {
test filebox-7.1-$mode "tk_getOpenFile - directory not readable" \
-constraints nonUnixUserInteraction \
-setup {
rename ::tk_messageBox ::saved_messageBox
set ::gotmessage {}
proc tk_messageBox args {
set ::gotmessage $args
}
toplevel .t1
file mkdir [file join $fileDir NOTREADABLE]
file attributes [file join $fileDir NOTREADABLE] \
-permissions 300
} \
-cleanup {
rename ::tk_messageBox {}
rename ::saved_messageBox ::tk_messageBox
unset ::gotmessage
destroy .t1
file delete -force [file join $fileDir NOTREADABLE]
} \
-body {
ToEnterFileByKey .t1 NOTREADABLE $fileDir
ToPressButton .t1 ok
ToPressButton .t1 cancel
tk_getOpenFile -parent .t1 \
-title "Please select the NOTREADABLE directory" \
-initialdir $fileDir
set gotmessage
} \
-match glob \
-result "*NOTREADABLE*"
test filebox-7.2-$mode "tk_getOpenFile - bad file name" \
-constraints nonUnixUserInteraction \
-setup {
rename ::tk_messageBox ::saved_messageBox
set ::gotmessage {}
proc tk_messageBox args {
set ::gotmessage $args
}
toplevel .t1
} \
-cleanup {
rename ::tk_messageBox {}
rename ::saved_messageBox ::tk_messageBox
unset ::gotmessage
destroy .t1
} \
-body {
ToEnterFileByKey .t1 RUBBISH $fileDir
ToPressButton .t1 ok
ToPressButton .t1 cancel
tk_getOpenFile -parent .t1 \
-title "Please enter RUBBISH as a file name" \
-initialdir $fileDir
set gotmessage
} \
-match glob \
-result "*RUBBISH*"
}
# The rest of the tests need to be executed on Unix only.
# The test whether the dialog box widgets were implemented correctly.
# These tests are not
# needed on the other platforms because they use native file dialogs.
}
set tk_strictMotif $tk_strictMotif_old
# cleanup
removeFile filebox.tmp
cleanupTests
return

27
tests/flagdown.xbm Normal file
View File

@@ -0,0 +1,27 @@
#define flagdown_width 48
#define flagdown_height 48
static char flagdown_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00,
0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xe1, 0x00, 0x00,
0x00, 0x00, 0x70, 0x80, 0x01, 0x00, 0x00, 0x00, 0x18, 0x00, 0x03, 0x00,
0x00, 0x00, 0x0c, 0x00, 0x03, 0x00, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04,
0x00, 0x00, 0x03, 0x00, 0x06, 0x06, 0x00, 0x80, 0x01, 0x00, 0x06, 0x07,
0x00, 0xc0, 0x1f, 0x00, 0x87, 0x07, 0x00, 0xe0, 0x7f, 0x80, 0xc7, 0x07,
0x00, 0x70, 0xe0, 0xc0, 0xe5, 0x07, 0x00, 0x38, 0x80, 0xe1, 0x74, 0x07,
0x00, 0x18, 0x80, 0x71, 0x3c, 0x07, 0x00, 0x0c, 0x00, 0x3b, 0x1e, 0x03,
0x00, 0x0c, 0x00, 0x1f, 0x0f, 0x00, 0x00, 0x86, 0x1f, 0x8e, 0x07, 0x00,
0x00, 0x06, 0x06, 0xc6, 0x05, 0x00, 0x00, 0x06, 0x00, 0xc6, 0x05, 0x00,
0x00, 0x06, 0x00, 0xc6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
0x7f, 0x06, 0x00, 0x06, 0xe4, 0xff, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
0x00, 0x06, 0x00, 0x06, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x06, 0x00,
0x00, 0x06, 0x00, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
0x00, 0x06, 0x00, 0xc6, 0x00, 0x00, 0x00, 0x06, 0x00, 0x66, 0x00, 0x00,
0x00, 0x06, 0x00, 0x36, 0x00, 0x00, 0x00, 0x06, 0x00, 0x3e, 0x00, 0x00,
0x00, 0xfe, 0xff, 0x2f, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x27, 0x00, 0x00,
0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
0xf7, 0xbf, 0x8e, 0xfc, 0xdf, 0xf8, 0x9d, 0xeb, 0x9b, 0x76, 0xd2, 0x7a,
0x46, 0x30, 0xe2, 0x0f, 0xe1, 0x47, 0x55, 0x84, 0x48, 0x11, 0x84, 0x19};

27
tests/flagup.xbm Normal file
View File

@@ -0,0 +1,27 @@
#define flagup_width 48
#define flagup_height 48
static char flagup_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00,
0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xef, 0x6a, 0x00,
0x00, 0x00, 0xc0, 0x7b, 0x75, 0x00, 0x00, 0x00, 0xe0, 0xe0, 0x6a, 0x00,
0x00, 0x00, 0x30, 0x60, 0x75, 0x00, 0x00, 0x00, 0x18, 0xe0, 0x7f, 0x00,
0x00, 0x00, 0x0c, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x06, 0xe0, 0x04, 0x00,
0x00, 0x00, 0x03, 0xe0, 0x04, 0x00, 0x00, 0x80, 0x01, 0xe0, 0x06, 0x00,
0x00, 0xc0, 0x1f, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x7f, 0xe0, 0x07, 0x00,
0x00, 0x70, 0xe0, 0xe0, 0x05, 0x00, 0x00, 0x38, 0x80, 0xe1, 0x04, 0x00,
0x00, 0x18, 0x80, 0xf1, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xfb, 0x04, 0x00,
0x00, 0x0c, 0x00, 0xff, 0x04, 0x00, 0x00, 0x86, 0x1f, 0xee, 0x04, 0x00,
0x00, 0x06, 0x06, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00,
0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x66, 0x04, 0x00,
0x7f, 0x56, 0x52, 0x06, 0xe4, 0xff, 0x00, 0x76, 0x55, 0x06, 0x04, 0x00,
0x00, 0x56, 0x57, 0x06, 0x04, 0x00, 0x00, 0x56, 0x55, 0x06, 0x06, 0x00,
0x00, 0x56, 0xd5, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
0x54, 0x06, 0x00, 0xc6, 0x54, 0x55, 0xaa, 0x06, 0x00, 0x66, 0xaa, 0x2a,
0x54, 0x06, 0x00, 0x36, 0x55, 0x55, 0xaa, 0x06, 0x00, 0xbe, 0xaa, 0x2a,
0x54, 0xfe, 0xff, 0x6f, 0x55, 0x55, 0xaa, 0xfc, 0xff, 0xa7, 0xaa, 0x2a,
0x54, 0x01, 0x88, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
0x54, 0x55, 0x8d, 0x50, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa8, 0xaa, 0x2a,
0x54, 0x55, 0x95, 0x54, 0x55, 0x55, 0xaa, 0xaa, 0xaa, 0xaa, 0xaa, 0x2a,
0x54, 0x55, 0x55, 0x55, 0x55, 0x15, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};

739
tests/focus.test Normal file
View File

@@ -0,0 +1,739 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
proc focusSetup {} {
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
destroy .alt
toplevel .alt -screen $env(TK_ALT_DISPLAY)
foreach i {a b c d} {
button .alt.$i -text .alt.$i -relief raised -bd 2
pack .alt.$i
}
tkwait visibility .alt.d
}
# 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.
proc focusClear {} {
global x;
after 200 {set x 1}
tkwait variable x
dobg {focus -force .; update}
update
}
# Button used in some tests in the whole test file
button .b -text .b -relief raised -bd 2
pack .b
# Make sure the window manager knows who has focus
catch {fixfocus}
# cleanupbg will be after 4.3 test
setupbg
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"
}
focusSetup
if {[testConstraint altDisplay]} {
focusSetupAlt
}
test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body {
focusClear
focus
} -result {}
test focus-1.2 {Tk_FocusCmd procedure} -constraints {
unix altDisplay
} -body {
focus .alt.b
focus
} -result {}
test focus-1.3 {Tk_FocusCmd procedure} -constraints unix -body {
focusClear
focus .t.b3
focus
} -result {}
test focus-1.4 {Tk_FocusCmd procedure} -constraints unix -body {
focus ""
} -returnCodes ok -result {}
test focus-1.5 {Tk_FocusCmd procedure} -constraints unix -body {
focusClear
focus -force .t
focus .t.b3
focus
} -result {.t.b3}
test focus-1.6 {Tk_FocusCmd procedure} -constraints unix -body {
focus .gorp
} -returnCodes error -result {bad window path name ".gorp"}
test focus-1.7 {Tk_FocusCmd procedure} -constraints unix -body {
focus .gorp a
} -returnCodes error -result {bad option ".gorp": must be -displayof, -force, or -lastfor}
test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} -constraints {
unix
} -setup {
destroy .t2
} -body {
focusClear
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
return $x
} -cleanup {
destroy .t2
} -result {.t2.f2 .t2 .t2}
test focus-1.9 {Tk_FocusCmd procedure, -displayof option} -constraints {
unix
} -body {
focus -displayof
} -returnCodes error -result {wrong # args: should be "focus -displayof window"}
test focus-1.10 {Tk_FocusCmd procedure, -displayof option} -constraints {
unix
} -body {
focus -displayof a b
} -returnCodes error -result {wrong # args: should be "focus -displayof window"}
test focus-1.11 {Tk_FocusCmd procedure, -displayof option} -constraints {
unix
} -body {
focus -displayof .lousy
} -returnCodes error -result {bad window path name ".lousy"}
test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints {
unix
} -body {
focusClear
focus .t
focus -displayof .t.b3
} -result {}
test focus-1.13 {Tk_FocusCmd procedure, -displayof option} -constraints {
unix
} -body {
focusClear
focus -force .t
focus -displayof .t.b3
} -result {.t}
test focus-1.14 {Tk_FocusCmd procedure, -displayof option} -constraints {
unix altDisplay
} -body {
focusClear
focus -force .alt.c
focus -displayof .alt
} -result {.alt.c}
test focus-1.15 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
focus -force
} -returnCodes error -result {wrong # args: should be "focus -force window"}
test focus-1.16 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
focus -force a b
} -returnCodes error -result {wrong # args: should be "focus -force window"}
test focus-1.17 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
focus -force foo
} -returnCodes error -result {bad window path name "foo"}
test focus-1.18 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
focus -force ""
} -returnCodes ok -result {}
test focus-1.19 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
focusClear
focus .t.b1
set x [list [focus]]
focus -force .t.b1
lappend x [focus]
} -result {{} .t.b1}
test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} -constraints {
unix
} -body {
focus -lastfor
} -returnCodes error -result {wrong # args: should be "focus -lastfor window"}
test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} -constraints {
unix
} -body {
focus -lastfor 1 2
} -returnCodes error -result {wrong # args: should be "focus -lastfor window"}
test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} -constraints {
unix
} -body {
focus -lastfor who_knows?
} -returnCodes error -result {bad window path name "who_knows?"}
test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} -constraints {
unix
} -body {
focusClear
focusSetup
focus .b
focus .t.b1
list [focus -lastfor .] [focus -lastfor .t.b3]
} -result {.b .t.b1}
test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} -constraints {
unix
} -body {
focusClear
focusSetup
update
focus -lastfor .t.b2
} -result {.t}
test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body {
focus -unknown
} -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor}
focusSetup
test focus-2.1 {TkFocusFilterEvent procedure} -constraints {
unix nonPortable testwrapper
} -body {
focusClear
focus -force .b
focusSetup
update
set focusInfo {}
event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor \
-sendevent 0x54217567
return $focusInfo
} -result {}
test focus-2.2 {TkFocusFilterEvent procedure} -constraints {
unix nonPortable testwrapper
} -body {
focusClear
focus -force .b
focusSetup
update
set focusInfo {}
event gen .t <FocusIn> -detail NotifyAncestor -sendevent 0x547321ac
list $focusInfo [focus]
} -result {{in .t NotifyAncestor
} .b}
test focus-2.3 {TkFocusFilterEvent procedure} -constraints {
unix nonPortable testwrapper
} -body {
focusClear
focus -force .b
focusSetup
update
set focusInfo {}
event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
update
list $focusInfo [focus -lastfor .t]
} -result {{out .b NotifyNonlinear
out . NotifyNonlinearVirtual
in .t NotifyNonlinear
} .t}
test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} -constraints {
unix nonPortable testwrapper
} -body {
focusClear
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
}
return $result
} -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} -constraints {
unix nonPortable testwrapper
} -body {
focusSetup
focus .t.b1
update
event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
list $focusInfo [focus]
} -result {{out . NotifyNonlinear
in .t NotifyNonlinearVirtual
in .t.b1 NotifyNonlinear
} .t.b1}
test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints {
unix testwrapper
} -body {
focus .t.b1
focus .
update
event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
set focusInfo {}
set x [focus]
event gen . <KeyPress-x>
list $x $focusInfo
} -result {.t.b1 {press .t.b1 x}}
test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
unix testwrapper
} -body {
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]
}
return $result
} -result {{} .t.b1 {} {} .t.b1 .t.b1 {}}
test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
unix testwrapper
} -body {
focus -force .t.b1
event gen .t.b1 <FocusOut> -detail NotifyAncestor
focus
} -result {.t.b1}
test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
unix testwrapper
} -body {
focus .t.b1
event gen [testwrapper .] <FocusOut> -detail NotifyAncestor
focus
} -result {}
test focus-2.10 {TkFocusFilterEvent procedure, Enter events} -constraints {
unix testwrapper
} -body {
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
}
return $result
} -result {.t.b1 {} .t.b1 .t.b1 .t.b1}
test focus-2.11 {TkFocusFilterEvent procedure, Enter events} -constraints {
unix testwrapper
} -body {
focusClear
set focusInfo {}
event gen [testwrapper .t] <Enter> -detail NotifyAncestor
update
return $focusInfo
} -result {}
test focus-2.12 {TkFocusFilterEvent procedure, Enter events} -constraints {
unix testwrapper
} -body {
focus -force .b
update
set focusInfo {}
event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
update
return $focusInfo
} -result {}
test focus-2.13 {TkFocusFilterEvent procedure, Enter events} -constraints {
unix testwrapper
} -body {
focus .t.b1
focusClear
event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
set focusInfo {}
update
return $focusInfo
} -result {in .t NotifyVirtual
in .t.b1 NotifyAncestor
}
test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} -constraints {
unix testwrapper
} -setup {
destroy .t2
set focusInfo {}
} -body {
focusClear
toplevel .t2
wm withdraw .t2
update
event gen [testwrapper .t2] <Enter> -detail NotifyAncestor -focus 1
update
} -cleanup {
destroy .t2
} -result {}
test focus-2.15 {TkFocusFilterEvent procedure, Leave events} -constraints {
unix testwrapper
} -body {
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]
}
return $result
} -result {{} .t.b1 {} {} {}}
test focus-2.16 {TkFocusFilterEvent procedure, Leave events} -constraints {
unix testwrapper
} -body {
focusClear
focus .t.b1
event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
update
set focusInfo {}
event gen [testwrapper .t] <Leave> -detail NotifyAncestor
update
return $focusInfo
} -result {out .t.b1 NotifyAncestor
out .t NotifyVirtual
}
test focus-2.17 {TkFocusFilterEvent procedure, Leave events} -constraints {
unix testwrapper
} -body {
focusClear
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]
} -result {{out .t.b1 NotifyAncestor
out .t NotifyVirtual
} {}}
test focus-3.1 {SetFocus procedure, create record on focus} -constraints {
unix testwrapper
} -body {
toplevel .t2 -width 250 -height 100
wm geometry .t2 +0+0
update
focus -force .t2
update
focus
} -cleanup {
destroy .t2
} -result {.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} -constraints {
unix testwrapper
} -body {
update
button .b2 -text "Another button"
focus .b2
update
} -cleanup {
destroy .b2
update
} -result {}
# 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} -constraints {
unix testwrapper
} -body {
focusSetup
focus -force .t.b2
update
} -result {}
test focus-3.4 {SetFocus procedure, delaying claim of X focus} -constraints {
unix testwrapper
} -body {
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
} -cleanup {
destroy .t2
} -result {}
test focus-3.5 {SetFocus procedure, generating events} -constraints {
unix testwrapper
} -body {
focusSetup
focusClear
set focusInfo {}
focus -force .t.b2
update
return $focusInfo
} -result {in .t NotifyVirtual
in .t.b2 NotifyAncestor
}
test focus-3.6 {SetFocus procedure, generating events} -constraints {
unix testwrapper
} -body {
focusSetup
focus -force .b
update
set focusInfo {}
focus .t.b2
update
return $focusInfo
} -result {out .b NotifyNonlinear
out . NotifyNonlinearVirtual
in .t NotifyNonlinearVirtual
in .t.b2 NotifyNonlinear
}
test focus-3.7 {SetFocus procedure, generating events} -constraints {
unix nonPortable testwrapper
} -body {
# Non-portable because some platforms generate extra events.
focusSetup
focusClear
set focusInfo {}
focus .t.b2
update
return $focusInfo
} -result {}
test focus-4.1 {TkFocusDeadWindow procedure} -constraints {
unix testwrapper
} -body {
focusSetup
update
focus -force .b
update
destroy .t
focus
} -result {.b}
test focus-4.2 {TkFocusDeadWindow procedure} -constraints {
unix testwrapper
} -body {
focusSetup
update
focus -force .t.b2
focus .b
update
destroy .t.b2
update
focus
} -result {.b}
# Non-portable due to wm-specific redirection of input focus when
# windows are deleted:
test focus-4.3 {TkFocusDeadWindow procedure} -constraints {
unix nonPortable testwrapper
} -body {
focusSetup
update
focus .t
update
destroy .t
update
focus
} -result {}
test focus-4.4 {TkFocusDeadWindow procedure} -constraints {
unix testwrapper
} -body {
focusSetup
focus -force .t.b2
update
destroy .t.b2
focus
} -result {.t}
cleanupbg
# 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 5.1 fails (before and after update)
test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constraints {
unix testwrapper secureserver
} -body {
setupbg
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]
} -cleanup {
cleanupbg
} -result {.t {} {}}
destroy .t
bind all <FocusIn> {}
bind all <FocusOut> {}
bind all <KeyPress> {}
fixfocus
test focus-6.1 {miscellaneous - embedded application in same process} -constraints {
unix testwrapper
} -setup {
eval interp delete [interp slaves]
} -body {
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}]]
return $result
} -cleanup {
interp delete child
destroy .t
bind all <FocusIn> {}
bind all <FocusOut> {}
} -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} -constraints {
unix testwrapper
} -body {
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}]]
return $result
} -cleanup {
destroy .t
cleanupbg
bind all <FocusIn> {}
bind all <FocusOut> {}
} -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}}}
deleteWindows
# cleanup
cleanupTests
return

485
tests/focusTcl.test Normal file
View File

@@ -0,0 +1,485 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
option add *takeFocus 1
option add *highlightThickness 2
. configure -takefocus 1 -highlightthickness 2
proc setup1 w {
if {$w == "."} {
set w ""
}
foreach i {a b c d} {
destroy $w.$i
frame $w.$i -width 200 -height 50 -bd 2 -relief raised
pack $w.$i
}
.b configure -width 0 -height 0
foreach i {x y z} {
destroy $w.b.$i
button $w.b.$i -text "Button $w.b.$i"
pack $w.b.$i -side left
}
if {![winfo ismapped $w.b.z]} {
tkwait visibility $w.b.z
}
}
proc cleanup1 w {
if {$w == "."} {
set w ""
}
foreach i {a b c d} {
destroy $w.$i
}
foreach i {x y z} {
destroy $w.b.$i
}
}
test focusTcl-1.1 {tk_focusNext procedure, no children} -body {
tk_focusNext .
} -result {.}
test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
tk_focusNext .
} -cleanup {
cleanup1 .
} -result {.a}
test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
tk_focusNext .a
} -cleanup {
cleanup1 .
} -result {.b}
test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
tk_focusNext .b
} -cleanup {
cleanup1 .
} -result {.b.x}
test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
tk_focusNext .b.x
} -cleanup {
cleanup1 .
} -result {.b.y}
test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
tk_focusNext .b.y
} -cleanup {
cleanup1 .
} -result {.b.z}
test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
tk_focusNext .b.z
} -cleanup {
cleanup1 .
} -result {.c}
test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
tk_focusNext .c
} -cleanup {
cleanup1 .
} -result {.d}
test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
tk_focusNext .d
} -cleanup {
cleanup1 .
} -result {.}
test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
foreach w {.b .b.x .b.y .c .d} {
$w configure -takefocus 0
}
tk_focusNext .a
} -cleanup {
cleanup1 .
} -result {.b.z}
test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
foreach w {.b .b.x .b.y .c .d} {
$w configure -takefocus 0
}
tk_focusNext .b.z
} -cleanup {
cleanup1 .
} -result {.}
test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} -body {
setup1 .
deleteWindows
setup1 .
update
. configure -takefocus 0
tk_focusNext .d
} -cleanup {
. configure -takefocus 1
cleanup1 .
} -result {.a}
test focusTcl-2.1 {tk_focusNext procedure, toplevels} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
tk_focusNext .a
} -cleanup {
deleteWindows
} -result {.b}
test focusTcl-2.2 {tk_focusNext procedure, toplevels} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
tk_focusNext .d
} -cleanup {
deleteWindows
} -result {.}
test focusTcl-2.3 {tk_focusNext procedure, toplevels} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
tk_focusNext .t
} -cleanup {
deleteWindows
} -result {.t}
test focusTcl-2.4 {tk_focusNext procedure, toplevels} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
setup1 .t
raise .t.b
tk_focusNext .t
} -cleanup {
deleteWindows
} -result {.t.a}
test focusTcl-2.5 {tk_focusNext procedure, toplevels} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
setup1 .t
raise .t.b
tk_focusNext .t.b.z
} -cleanup {
deleteWindows
} -result {.t}
test focusTcl-3.1 {tk_focusPrev procedure, no children} -body {
tk_focusPrev .
} -result {.}
test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} -body {
setup1 .
tk_focusPrev .
} -cleanup {
cleanup1 .
} -result {.d}
test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} -body {
setup1 .
tk_focusPrev .d
} -cleanup {
cleanup1 .
} -result {.c}
test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} -body {
setup1 .
tk_focusPrev .c
} -cleanup {
cleanup1 .
} -result {.b.z}
test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} -body {
setup1 .
tk_focusPrev .b.z
} -cleanup {
cleanup1 .
} -result {.b.y}
test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} -body {
setup1 .
tk_focusPrev .b.y
} -cleanup {
cleanup1 .
} -result {.b.x}
test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} -body {
setup1 .
tk_focusPrev .b.x
} -cleanup {
cleanup1 .
} -result {.b}
test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} -body {
setup1 .
tk_focusPrev .b
} -cleanup {
cleanup1 .
} -result {.a}
test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} -body {
setup1 .
tk_focusPrev .a
} -cleanup {
cleanup1 .
} -result {.}
deleteWindows
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} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
tk_focusPrev .
} -cleanup {
deleteWindows
} -result {.d}
test focusTcl-4.2 {tk_focusPrev procedure, toplevels} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
tk_focusPrev .b
} -cleanup {
deleteWindows
} -result {.a}
test focusTcl-4.3 {tk_focusPrev procedure, toplevels} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
tk_focusPrev .t
} -cleanup {
deleteWindows
} -result {.t}
test focusTcl-4.4 {tk_focusPrev procedure, toplevels} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
setup1 .t
update
.t configure -takefocus 0
raise .t.b
tk_focusPrev .t
} -cleanup {
deleteWindows
} -result {.t.b.z}
test focusTcl-4.5 {tk_focusPrev procedure, toplevels} -setup {
deleteWindows
} -body {
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
setup1 .t
update
.t configure -takefocus 0
raise .t.b
tk_focusPrev .t.a
} -cleanup {
deleteWindows
} -result {.t.b.z}
test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} -body {
setup1 .
.b.x configure -takefocus 0
tk_focusNext .b
} -cleanup {
cleanup1 .
} -result {.b.y}
test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} -body {
setup1 .
pack forget .b
update
.b configure -takefocus ""
.b.y configure -takefocus ""
.b.z configure -takefocus ""
list [tk_focusNext .a] [tk_focusNext .b.x]
} -cleanup {
cleanup1 .
} -result {.c .c}
test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} -body {
proc t w {
if {$w == ".b.x"} {
return 1
} elseif {$w == ".b.y"} {
return ""
}
return 0
}
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]
} -cleanup {
cleanup1 .
} -result {.b.x .d}
test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} -body {
setup1 .
.b.x configure -takefocus ""
update
tk_focusNext .b
} -cleanup {
cleanup1 .
} -result {.b.x}
test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} -body {
setup1 .
.b.x configure -takefocus ""
pack unpack .b.x
update
tk_focusNext .b
} -cleanup {
cleanup1 .
} -result {.b.y}
test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} -body {
setup1 .
foreach w {.b.x .b.y .b.z} {
$w configure -takefocus ""
}
pack unpack .b
update
tk_focusNext .b
} -cleanup {
cleanup1 .
} -result {.c}
test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} -body {
setup1 .
.b.y configure -takefocus 1
pack unpack .b.y
update
tk_focusNext .b.x
} -cleanup {
cleanup1 .
} -result {.b.z}
test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} -body {
proc always args {return 1}
setup1 .
.b.y configure -takefocus always
pack unpack .b.y
update
tk_focusNext .b.x
} -cleanup {
cleanup1 .
} -result {.b.y}
test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} -body {
setup1 .
foreach w {.b.x .b.y .b.z} {
$w configure -takefocus ""
}
update
.b.x configure -state disabled
tk_focusNext .b
} -cleanup {
cleanup1 .
} -result {.b.y}
test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} -body {
setup1 .
foreach w {.a .b .c .d} {
$w configure -takefocus ""
}
update
bind .a <Key> {foo}
list [tk_focusNext .] [tk_focusNext .a]
} -cleanup {
cleanup1 .
} -result {.a .b.x}
test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} -body {
setup1 .
foreach w {.a .b .c .d} {
$w configure -takefocus ""
}
update
bind Frame <Key> {foo}
list [tk_focusNext .] [tk_focusNext .a]
} -cleanup {
cleanup1 .
bind Frame <Key> {}
} -result {.a .b}
. configure -takefocus 0 -highlightthickness 0
option clear
# cleanup
cleanupTests
return

2382
tests/font.test Normal file
View File

File diff suppressed because it is too large Load Diff

201
tests/fontchooser.test Normal file
View File

@@ -0,0 +1,201 @@
# Test the "tk::fontchooser" command
#
# Copyright (c) 2008 Pat Thoyts
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
# the following helper functions are related to the functions used
# in winDialog.test where they are used to send messages to the win32
# dialog (hence the wierdness).
proc start {cmd} {
set ::tk_dialog {}
set ::iter_after 0
after 1 $cmd
}
proc then {cmd} {
set ::command $cmd
set ::dialogresult {}
set ::testfont {}
afterbody
vwait ::dialogresult
return $::dialogresult
}
proc afterbody {} {
if {$::tk_dialog == {}} {
if {[incr ::iter_after] > 30} {
set ::dialogresult ">30 iterations waiting for tk_dialog"
return
}
after 150 {afterbody}
return
}
uplevel #0 {set dialogresult [eval $command]}
}
proc Click {button} {
switch -exact -- $button {
ok { $::tk_dialog.ok invoke }
cancel { $::tk_dialog.cancel invoke }
apply { $::tk_dialog.apply invoke }
default { return -code error "invalid button name \"$button\"" }
}
}
proc ApplyFont {font} {
# puts stderr "apply: $font"
set ::testfont $font
}
# -------------------------------------------------------------------------
test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser -z
} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show}
test fontchooser-1.2 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -z
} -match glob -result {bad option "-z":*}
test fontchooser-1.3 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -parent . -font
} -result {value for "-font" missing}
test fontchooser-1.4 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -parent . -title
} -result {value for "-title" missing}
test fontchooser-1.5 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -parent . -command
} -result {value for "-command" missing}
test fontchooser-1.6 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -title . -parent
} -result {value for "-parent" missing}
test fontchooser-1.7 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -parent abc
} -result {bad window path name "abc"}
test fontchooser-1.8 {tk fontchooser: usage} -returnCodes ok -body {
tk fontchooser configure -visible
} -result {0}
test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -visible 1
} -match glob -result {*}
# -------------------------------------------------------------------------
#
# The remaining tests in this file are only relevant for the script
# implementation. They can be tested by sourcing the script file but
# the Tk tests are run with -singleproc 1 and doing this affects the
# result of later attempts to test the native implementations.
#
testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]
test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -title "Hello"
tk::fontchooser::Show
}
then {
set x [wm title $::tk_dialog]
Click cancel
}
set x
} -result {Hello}
test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure \
-title "\u041f\u0440\u0438\u0432\u0435\u0442"
tk::fontchooser::Show
}
then {
set x [wm title $::tk_dialog]
Click cancel
}
set x
} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -parent .
tk::fontchooser::Show
}
then {
set x [winfo parent $::tk_dialog]
Click cancel
}
set x
} -result {.}
test fontchooser-3.1 {fontchooser -parent (invalid)} -constraints scriptImpl -body {
tk::fontchooser::Configure -parent junk
} -returnCodes error -match glob -result {bad window path *}
test fontchooser-4.0 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font courier
tk::fontchooser::Show
}
then {
Click cancel
}
set ::testfont
} -result {}
test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font courier
tk::fontchooser::Show
}
then {
Click ok
}
expr {$::testfont ne {}}
} -result {1}
test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font TkDefaultFont
tk::fontchooser::Show
}
then {
Click ok
}
expr {$::testfont ne {}}
} -result {1}
test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
tk::fontchooser::Show
}
then {
Click ok
}
expr {$::testfont ne {}}
} -result {1}
test fontchooser-4.4 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
tk::fontchooser::Show
}
then {
Click ok
}
lrange $::testfont 1 end
} -result {14 bold}
# -------------------------------------------------------------------------
cleanupTests
return
# Local Variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

1529
tests/frame.test Normal file
View File

File diff suppressed because it is too large Load Diff

291
tests/geometry.test Normal file
View File

@@ -0,0 +1,291 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
proc getsize w {
regexp {(^[^+-]*)} [wm geometry $w] foo x
return $x
}
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
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} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
place .b1 -x 120 -y 80
update
list [winfo x .b1] [winfo y .b1]
} -result {120 80}
test geometry-1.2 {Tk_ManageGeometry procedure} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -result {0 0}
test geometry-2.1 {Tk_GeometryRequest procedure} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
destroy .f2
} -body {
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]
} -cleanup {
destroy .f2
} -result {1 1 150 300 1x1+0+0 150x300+10+20 100x80+10+20}
test geometry-3.1 {Tk_SetInternalBorder procedure} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -cleanup {
.f configure -bd 2
} -result {72 37 75 40}
test geometry-4.1 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -result {91 46}
test geometry-4.2 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -result {101 41 61 61 101 61}
test geometry-4.3 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -result {0 0 46 86 86 86}
test geometry-4.4 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -result {93 49 0 0 93 69}
test geometry-4.5 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -result {93 49 53 69 0 0}
test geometry-4.6 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -result {54 9 56 71}
test geometry-4.7 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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
return $x
} -cleanup {
bind .b1 <Configure> {}
} -result {init configure |}
test geometry-4.8 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -result {91 46 0 51 66 0 91 66 0}
test geometry-4.9 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
} -body {
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]
} -result {1 0 1}
test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
place forget $w
}
destroy .t
} -body {
toplevel .t
wm geometry .t +0+0
tkwait visibility .t
update
pack [frame .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
} -cleanup {
destroy .t
} -result {1}
# cleanup
cleanupTests
return

138
tests/get.test Normal file
View File

@@ -0,0 +1,138 @@
# This file is a Tcl script to test out the procedures in the file
# tkGet.c. It is organized in the standard fashion for Tcl
# white-box tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
test get-1.1 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor n
.b cget -anchor
} -cleanup {
destroy .b
} -result {n}
test get-1.2 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor ne
.b cget -anchor
} -cleanup {
destroy .b
} -result {ne}
test get-1.3 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor e
.b cget -anchor
} -cleanup {
destroy .b
} -result {e}
test get-1.4 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor se
.b cget -anchor
} -cleanup {
destroy .b
} -result {se}
test get-1.5 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor s
.b cget -anchor
} -cleanup {
destroy .b
} -result {s}
test get-1.6 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor sw
.b cget -anchor
} -cleanup {
destroy .b
} -result {sw}
test get-1.7 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor w
.b cget -anchor
} -cleanup {
destroy .b
} -result {w}
test get-1.8 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor nw
.b cget -anchor
} -cleanup {
destroy .b
} -result {nw}
test get-1.9 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor n
.b cget -anchor
} -cleanup {
destroy .b
} -result {n}
test get-1.10 {Tk_GetAnchorFromObj} -setup {
button .b
} -body {
.b configure -anchor center
.b cget -anchor
} -cleanup {
destroy .b
} -result {center}
test get-1.11 {Tk_GetAnchorFromObj - error} -setup {
button .b
} -body {
.b configure -anchor unknown
} -cleanup {
destroy .b
} -returnCodes {error} -result {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center}
test get-2.1 {Tk_GetJustifyFromObj} -setup {
button .b
} -body {
.b configure -justify left
.b cget -justify
} -cleanup {
destroy .b
} -result {left}
test get-2.2 {Tk_GetJustifyFromObj} -setup {
button .b
} -body {
.b configure -justify right
.b cget -justify
} -cleanup {
destroy .b
} -result {right}
test get-2.3 {Tk_GetJustifyFromObj} -setup {
button .b
} -body {
.b configure -justify center
.b cget -justify
} -cleanup {
destroy .b
} -result {center}
test get-2.4 {Tk_GetJustifyFromObj - error} -setup {
button .b
} -body {
.b configure -justify stupid
} -cleanup {
destroy .b
} -returnCodes {error} -result {bad justification "stupid": must be left, right, or center}
# cleanup
cleanupTests
return

188
tests/grab.test Normal file
View File

@@ -0,0 +1,188 @@
# Tests for the grab command.
#
# This file contains a collection of tests for one or more of the Tk
# built-in commands. Sourcing this file runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
# There's currently no way to test the actual grab effect, per se,
# in an automated test. Therefore, this test suite only covers the
# interface to the grab command (ie, error messages, etc.)
test grab-1.1 {Tk_GrabObjCmd} -body {
grab
} -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"}
test grab-1.2 {Tk_GrabObjCmd} -body {
rename grab grabTest1.2
grabTest1.2
} -cleanup {
rename grabTest1.2 grab
} -returnCodes error -result {wrong # args: should be "grabTest1.2 ?-global? window" or "grabTest1.2 option ?arg ...?"}
test grab-1.3 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
grab .foo bar baz
} -returnCodes error -result {wrong # args: should be "grab ?-global? window"}
test grab-1.4 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
destroy .foo
grab .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.5 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
grab -foo bar
} -returnCodes error -result {bad option "-foo": must be -global}
test grab-1.6 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
destroy .foo
grab -global .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.7 {Tk_GrabObjCmd} -body {
grab foo
} -returnCodes error -result {bad option "foo": must be current, release, set, or status}
test grab-1.8 {Tk_GrabObjCmd, "grab current ?window?"} -body {
grab current foo bar
} -returnCodes error -result {wrong # args: should be "grab current ?window?"}
test grab-1.9 {Tk_GrabObjCmd, "grab current ?window?"} -body {
destroy .foo
grab current .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.10 {Tk_GrabObjCmd, "grab release window"} -body {
grab release
} -returnCodes error -result {wrong # args: should be "grab release window"}
test grab-1.11 {Tk_GrabObjCmd, "grab release window"} -body {
destroy .foo
grab release .foo
} -returnCodes ok -result {}
test grab-1.12 {Tk_GrabObjCmd, "grab release window"} -body {
grab release foo
} -returnCodes ok -result {}
test grab-1.13 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
grab set
} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"}
test grab-1.14 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
grab set foo bar baz
} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"}
test grab-1.15 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
destroy .foo
grab set .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.16 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
grab set -foo bar
} -returnCodes error -result {bad option "-foo": must be -global}
test grab-1.17 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
destroy .foo
grab set -global .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.18 {Tk_GrabObjCmd, "grab status window"} -body {
grab status
} -returnCodes error -result {wrong # args: should be "grab status window"}
test grab-1.19 {Tk_GrabObjCmd, "grab status window"} -body {
grab status foo bar
} -returnCodes error -result {wrong # args: should be "grab status window"}
test grab-1.20 {Tk_GrabObjCmd, "grab status window"} -body {
destroy .foo
grab status .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab status .
} -cleanup {
grab release .
} -result {none}
test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab .
grab status .
} -cleanup {
grab release .
} -result {local}
test grab-2.3 {Tk_GrabObjCmd, grab status gives correct status} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab -global .
grab status .
} -cleanup {
grab release .
} -result {global}
test grab-3.1 {Tk_GrabObjCmd, grab current gives correct information} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
return $curr
} -result {}
test grab-3.2 {Tk_GrabObjCmd, grab current gives correct information} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab .
grab current
} -cleanup {
grab release .
} -result {.}
test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab .
set result [grab status .]
grab release .
lappend result [grab status .]
grab -global .
lappend result [grab status .]
grab release .
lappend result [grab status .]
} -result {local none global none}
test grab-5.1 {Tk_GrabObjCmd, grab set} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab set .
list [grab current .] [grab status .]
} -cleanup {
grab release .
} -result {. local}
test grab-5.2 {Tk_GrabObjCmd, grab set} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab set -global .
list [grab current .] [grab status .]
} -cleanup {
grab release .
} -result {. global}
cleanupTests
return

2008
tests/grid.test Normal file
View File

File diff suppressed because it is too large Load Diff

626
tests/image.test Normal file
View File

@@ -0,0 +1,626 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit
# Canvas used in some tests in the whole file
canvas .c -highlightthickness 2
pack .c
update
test image-1.1 {Tk_ImageCmd procedure, "create" option} -body {
image
} -returnCodes error -result {wrong # args: should be "image option ?args?"}
test image-1.2 {Tk_ImageCmd procedure, "create" option} -body {
image gorp
} -returnCodes error -result {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}
test image-1.3 {Tk_ImageCmd procedure, "create" option} -body {
image create
} -returnCodes error -result {wrong # args: should be "image create type ?name? ?-option value ...?"}
test image-1.4 {Tk_ImageCmd procedure, "create" option} -body {
image c bad_type
} -returnCodes error -result {image type "bad_type" doesn't exist}
test image-1.5 {Tk_ImageCmd procedure, "create" option} -constraints {
testImageType
} -body {
list [image create test myimage] [imageNames]
} -cleanup {
imageCleanup
} -result {myimage myimage}
test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints {
testImageType
} -setup {
imageCleanup
} -body {
scan [image create test] image%d first
image create test myimage
scan [image create test -variable x] image%d second
expr $second-$first
} -cleanup {
imageCleanup
} -result {1}
test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints {
testImageType
} -setup {
imageCleanup
} -body {
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
return $x
} -cleanup {
imageCleanup
} -result {{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} -constraints {
testImageType
} -setup {
.c delete all
imageCleanup
} -body {
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
return $x
} -cleanup {
.c delete all
imageCleanup
} -result {{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} -constraints {
testImageType
} -body {
image create test -badName foo
} -returnCodes error -result {bad option name "-badName"}
test image-1.10 {Tk_ImageCmd procedure, "create" option} -constraints {
testImageType
} -body {
catch {image create test -badName foo}
imageNames
} -result {}
test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window} -body {
set code [loadTkCommand]
append code {
update
puts [list [catch {image create photo .} msg] $msg]
exit
}
set script [makeFile $code script]
exec [interpreter] <$script
} -cleanup {
removeFile script
} -result {1 {images may not be named the same as the main window}}
test image-1.12 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} -body {
set code [loadTkCommand]
append code {
update
puts [list [catch {rename . foo;image create photo foo} msg] $msg]
exit
}
set script [makeFile $code script]
exec [interpreter] <$script
} -cleanup {
removeFile script
} -result {1 {images may not be named the same as the main window}}
test image-1.13 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup {
.c delete all
imageCleanup
} -body {
set i [image create bitmap]
regexp {^image(\d+)$} $i -> serial
incr serial
proc image$serial {} {return works}
set j [image create bitmap]
image$serial
} -cleanup {
rename image$serial {}
image delete $i $j
} -result works
test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body {
image delete
} -result {}
test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints {
testImageType
} -setup {
imageCleanup
set result {}
} -body {
image create test myimage
image create test img2
lappend result [lsort [imageNames]]
image d myimage img2
lappend result [imageNames]
} -cleanup {
imageCleanup
} -result {{img2 myimage} {}}
test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints {
testImageType
} -setup {
imageCleanup
} -body {
image create test myimage
image create test img2
image delete myimage gorp img2
} -cleanup {
imageCleanup
} -returnCodes error -result {image "gorp" doesn't exist}
test image-2.4 {Tk_ImageCmd procedure, "delete" option} -constraints {
testImageType
} -setup {
imageCleanup
} -body {
image create test myimage
image create test img2
catch {image delete myimage gorp img2}
imageNames
} -cleanup {
imageCleanup
} -result {img2}
test image-3.1 {Tk_ImageCmd procedure, "height" option} -body {
image height
} -returnCodes error -result {wrong # args: should be "image height name"}
test image-3.2 {Tk_ImageCmd procedure, "height" option} -body {
image height a b
} -returnCodes error -result {wrong # args: should be "image height name"}
test image-3.3 {Tk_ImageCmd procedure, "height" option} -body {
image height foo
} -returnCodes error -result {image "foo" doesn't exist}
test image-3.4 {Tk_ImageCmd procedure, "height" option} -constraints {
testImageType
} -setup {
imageCleanup
} -body {
image create test myimage
set x [image h myimage]
myimage changed 0 0 0 0 60 50
list $x [image height myimage]
} -cleanup {
imageCleanup
} -result {15 50}
test image-4.1 {Tk_ImageCmd procedure, "names" option} -body {
image names x
} -returnCodes error -result {wrong # args: should be "image names"}
test image-4.2 {Tk_ImageCmd procedure, "names" option} -constraints {
testImageType
} -setup {
catch {interp delete testinterp}
} -body {
interp create testinterp
load {} Tk testinterp
interp eval testinterp {
image delete {*}[image names]
image create test myimage
image create test img2
image create test 24613
lsort [image names]
}
} -cleanup {
interp delete testinterp
} -result {24613 img2 myimage}
test image-4.3 {Tk_ImageCmd procedure, "names" option} -setup {
catch {interp delete testinterp}
} -body {
interp create testinterp
load {} Tk testinterp
interp eval testinterp {
image delete {*}[image names]
eval image delete [image names] [image names]
lsort [image names]
}
} -cleanup {
interp delete testinterp
} -result {}
test image-5.1 {Tk_ImageCmd procedure, "type" option} -body {
image type
} -returnCodes error -result {wrong # args: should be "image type name"}
test image-5.2 {Tk_ImageCmd procedure, "type" option} -body {
image type a b
} -returnCodes error -result {wrong # args: should be "image type name"}
test image-5.3 {Tk_ImageCmd procedure, "type" option} -body {
image type foo
} -returnCodes error -result {image "foo" doesn't exist}
test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints {
testImageType
} -setup {
imageCleanup
} -body {
image create test myimage
image type myimage
} -cleanup {
imageCleanup
} -result {test}
test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints {
testImageType
} -setup {
imageCleanup
} -body {
image create test myimage
.c create image 50 50 -image myimage
image delete myimage
image type myimage
} -cleanup {
imageCleanup
} -returnCodes error -result {image "myimage" doesn't exist}
test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints {
testOldImageType
} -setup {
imageCleanup
} -body {
image create oldtest myimage
image type myimage
} -cleanup {
imageCleanup
} -result {oldtest}
test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints {
testOldImageType
} -setup {
.c delete all
imageCleanup
} -body {
image create oldtest myimage
.c create image 50 50 -image myimage
image delete myimage
image type myimage
} -cleanup {
.c delete all
imageCleanup
} -returnCodes error -result {image "myimage" doesn't exist}
test image-6.1 {Tk_ImageCmd procedure, "types" option} -body {
image types x
} -returnCodes error -result {wrong # args: should be "image types"}
test image-6.2 {Tk_ImageCmd procedure, "types" option} -constraints {
testImageType
} -body {
lsort [image types]
} -result {bitmap oldtest photo test}
test image-7.1 {Tk_ImageCmd procedure, "width" option} -body {
image width
} -returnCodes error -result {wrong # args: should be "image width name"}
test image-7.2 {Tk_ImageCmd procedure, "width" option} -body {
image width a b
} -returnCodes error -result {wrong # args: should be "image width name"}
test image-7.3 {Tk_ImageCmd procedure, "width" option} -body {
image width foo
} -returnCodes error -result {image "foo" doesn't exist}
test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints {
testImageType
} -setup {
imageCleanup
} -body {
image create test myimage
set x [image w myimage]
myimage changed 0 0 0 0 60 50
list $x [image width myimage]
} -cleanup {
imageCleanup
} -result {30 60}
test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints {
testImageType
} -setup {
imageCleanup
set res {}
destroy .b
} -body {
image create test myimage2
lappend res [image inuse myimage2]
button .b -image myimage2
lappend res [image inuse myimage2]
} -cleanup {
imageCleanup
catch {destroy .b}
} -result [list 0 1]
test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup {
.c delete all
imageCleanup
} -body {
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
return $x
} -cleanup {
.c delete all
imageCleanup
} -result {{foo display 5 6 7 8 30 30}}
test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup {
.c delete all
imageCleanup
} -body {
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
return $x
} -cleanup {
.c delete all
imageCleanup
} -result {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}}
test image-10.1 {Tk_GetImage procedure} -setup {
imageCleanup
} -body {
.c create image 100 10 -image bad_name
} -cleanup {
imageCleanup
} -returnCodes error -result {image "bad_name" doesn't exist}
test image-10.2 {Tk_GetImage procedure} -constraints testImageType -setup {
destroy .l
imageCleanup
} -body {
image create test mytest
label .l -image mytest
image delete mytest
label .l2 -image mytest
} -cleanup {
destroy .l
imageCleanup
} -returnCodes error -result {image "mytest" doesn't exist}
test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup {
.c delete all
imageCleanup
} -body {
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 [imageNames] $x
} -cleanup {
.c delete all
imageCleanup
} -result {foo {{foo free} {foo display 0 0 30 15 103 121}}}
test image-11.2 {Tk_FreeImage procedure} -constraints testImageType -setup {
.c delete all
imageCleanup
} -body {
image create test foo -variable x
.c create image 50 50 -image foo -tags i1
set names [imageNames]
image delete foo
update
set names2 [imageNames]
set x {}
.c delete i1
pack forget .c
pack .c
update
list $names $names2 [imageNames] $x
} -cleanup {
.c delete all
imageCleanup
} -result {foo {} {} {}}
# Non-portable, apparently due to differences in rounding:
test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
testImageType nonPortable
} -setup {
imageCleanup
} -body {
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
return $x
} -cleanup {
imageCleanup
} -result {{foo display 0 0 5 5 50 50}}
test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
testImageType nonPortable
} -setup {
imageCleanup
} -body {
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
return $x
} -cleanup {
imageCleanup
} -result {{foo display 10 0 20 5 30 50}}
test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
testImageType nonPortable
} -setup {
imageCleanup
} -body {
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
return $x
} -cleanup {
imageCleanup
} -result {{foo display 10 10 20 5 30 30}}
test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
testImageType nonPortable
} -setup {
imageCleanup
} -body {
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
return $x
} -cleanup {
imageCleanup
} -result {{foo display 0 10 5 5 50 30}}
test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
testImageType nonPortable
} -setup {
imageCleanup
} -body {
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
return $x
} -cleanup {
imageCleanup
} -result {{foo display 0 0 30 15 70 70}}
test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
testImageType nonPortable
} -setup {
imageCleanup
} -body {
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
return $x
} -cleanup {
imageCleanup
} -result {{foo display 5 5 20 5 30 30}}
test image-13.1 {Tk_SizeOfImage procedure} -constraints testImageType -setup {
imageCleanup
} -body {
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]
} -cleanup {
imageCleanup
} -result {30 15 85 60}
test image-13.2 {DeleteImage procedure} -constraints testImageType -setup {
.c delete all
imageCleanup
} -body {
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 | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] |
} -cleanup {
imageCleanup
} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |}
test image-13.3 {Tk_SizeOfImage procedure} -constraints testOldImageType -setup {
imageCleanup
} -body {
image create oldtest foo -variable x
set result [list [image width foo] [image height foo]]
foo changed 0 0 0 0 85 60
lappend result [image width foo] [image height foo]
} -cleanup {
imageCleanup
} -result {30 15 85 60}
test image-13.4 {DeleteImage procedure} -constraints testOldImageType -setup {
.c delete all
imageCleanup
} -body {
image create oldtest foo -variable x
.c create image 50 50 -image foo -tags i1
.c create image 90 100 -image foo -tags i2
set x {}
image delete foo
lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] |
} -cleanup {
.c delete all
imageCleanup
} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |}
test image-14.1 {image command vs hidden commands} -body {
catch {image delete hidden}
set l [imageNames]
set h [interp hidden]
image create photo hidden
interp hide {} hidden
image delete hidden
set res1 [list [imageNames] [interp hidden]]
set res2 [list $l $h]
expr {$res1 eq $res2}
} -result 1
test image-15.1 {deleting image does not make widgets forget about it} -setup {
.c delete all
imageCleanup
} -body {
image create photo foo -width 10 -height 10
.c create image 10 10 -image foo -tags i1 -anchor nw
update
set x [.c bbox i1]
lappend x [imageNames]
image delete foo
lappend x [imageNames]
image create photo foo -width 20 -height 20
lappend x [.c bbox i1] [imageNames]
} -cleanup {
.c delete all
imageCleanup
} -result {10 10 20 20 foo {} {10 10 30 30} foo}
destroy .c
imageFinish
# cleanup
cleanupTests
return
# Local variables:
# mode: tcl
# End:

519
tests/imgBmap.test Normal file
View File

@@ -0,0 +1,519 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit
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
imageCleanup
#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} -body {
image create bitmap i1 -background #123456
lindex [i1 configure -background] 4
} -cleanup {
image delete i1
} -result {#123456}
test imageBmap-1.2 {options for bitmap images} -setup {
destroy .c
pack [canvas .c]
update
} -body {
set errMsg {}
image create bitmap i1 -background lousy
.c create image 200 100 -image i1
update
list $errMsg $errorInfo
} -cleanup {
image delete i1
destroy .c
} -result {{unknown color name "lousy"} {unknown color name "lousy"
(while configuring image "i1")}}
test imageBmap-1.3 {options for bitmap images} -body {
image create bitmap i1 -data $data1
lindex [i1 configure -data] 4
} -result $data1
test imageBmap-1.4 {options for bitmap images} -body {
image create bitmap i1 -data bogus
} -returnCodes error -result {format error in bitmap data}
test imageBmap-1.5 {options for bitmap images} -body {
image create bitmap i1 -file foo.bm
lindex [i1 configure -file] 4
} -result foo.bm
test imageBmap-1.6 {options for bitmap images} -body {
list [catch {image create bitmap i1 -file bogus} msg] [string tolower $msg]
} -result {1 {couldn't read bitmap file "bogus": no such file or directory}}
test imageBmap-1.7 {options for bitmap images} -body {
image create bitmap i1 -foreground #00ff00
lindex [i1 configure -foreground] 4
} -cleanup {
image delete i1
} -result {#00ff00}
test imageBmap-1.8 {options for bitmap images} -setup {
destroy .c
pack [canvas .c]
update
} -body {
set errMsg {}
image create bitmap i1 -foreground bad_color
.c create image 200 100 -image i1
update
list $errMsg $errorInfo
} -cleanup {
destroy .c
image delete i1
} -result {{unknown color name "bad_color"} {unknown color name "bad_color"
(while configuring image "i1")}}
test imageBmap-1.9 {options for bitmap images} -body {
image create bitmap i1 -data $data1 -maskdata $data2
lindex [i1 configure -maskdata] 4
} -result $data2
test imageBmap-1.10 {options for bitmap images} -body {
image create bitmap i1 -data $data1 -maskdata bogus
} -returnCodes error -result {format error in bitmap data}
test imageBmap-1.11 {options for bitmap images} -body {
image create bitmap i1 -file foo.bm -maskfile foo2.bm
lindex [i1 configure -maskfile] 4
} -result foo2.bm
test imageBmap-1.12 {options for bitmap images} -body {
list [catch {image create bitmap i1 -data $data1 -maskfile bogus} msg] \
[string tolower $msg]
} -result {1 {couldn't read bitmap file "bogus": no such file or directory}}
rename bgerror {}
test imageBmap-2.1 {ImgBmapCreate procedure} -setup {
imageCleanup
} -body {
list [catch {image create bitmap -gorp dum} msg] $msg [imageNames]
} -result {1 {unknown option "-gorp"} {}}
test imageBmap-2.2 {ImgBmapCreate procedure} -setup {
imageCleanup
} -body {
image create bitmap image1
list [info commands image1] [imageNames] \
[image width image1] [image height image1] \
[lindex [image1 configure -foreground] 4] \
[lindex [image1 configure -background] 4]
} -cleanup {
image delete image1
} -result {image1 image1 0 0 #000000 {}}
test imageBmap-3.1 {ImgBmapConfigureMaster procedure, memory de-allocation} -body {
image create bitmap i1 -data $data1
i1 configure -data $data1
} -cleanup {
image delete i1
} -result {}
test imageBmap-3.2 {ImgBmapConfigureMaster procedure} -body {
image create bitmap i1 -data $data1
list [catch {i1 configure -data bogus} msg] $msg [image width i1] \
[image height i1]
} -result {1 {format error in bitmap data} 16 16}
test imageBmap-3.3 {ImgBmapConfigureMaster procedure, memory de-allocation} -body {
image create bitmap i1 -data $data1 -maskdata $data2
i1 configure -maskdata $data2
} -cleanup {
image delete i1
} -result {}
test imageBmap-3.4 {ImgBmapConfigureMaster procedure} -body {
image create bitmap i1
i1 configure -maskdata $data2
} -returnCodes error -result {can't have mask without bitmap}
test imageBmap-3.5 {ImgBmapConfigureMaster procedure} -body {
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};
}
} -returnCodes error -result {bitmap and mask have different sizes}
test imageBmap-3.6 {ImgBmapConfigureMaster procedure} -body {
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};
}
} -returnCodes error -result {bitmap and mask have different sizes}
test imageBmap-3.7 {ImgBmapConfigureMaster procedure} -setup {
destroy .c
pack [canvas .c]
} -body {
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]
} -cleanup {
image delete i1
destroy .c
} -result {15 14 {100 100 115 114} {200 100 215 114}}
test imageBmap-4.1 {ImgBmapConfigureInstance procedure: check error handling} -setup {
destroy .c
pack [canvas .c]
update
} -body {
proc bgerror args {}
image create bitmap i1 -file foo.bm
.c create image 100 100 -image i1
update
i1 configure -foreground bogus
update
} -cleanup {
image delete i1
destroy .c
} -result {}
test imageBmap-5.1 {GetBitmapData procedure} -body {
list [catch {image create bitmap -file ~bad_user/a/b} msg] \
[string tolower $msg]
} -result {1 {user "bad_user" doesn't exist}}
test imageBmap-5.2 {GetBitmapData procedure} -body {
list [catch {image create bitmap -file bad_name} msg] [string tolower $msg]
} -result {1 {couldn't read bitmap file "bad_name": no such file or directory}}
test imageBmap-5.3 {GetBitmapData procedure} -setup {imageCleanup} -body {
image create bitmap -data { }
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.4 {GetBitmapData procedure} -setup {imageCleanup} -body {
image create bitmap -data "#define foo2_width"
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.5 {GetBitmapData procedure} -setup {imageCleanup} -body {
image create bitmap -data "#define foo2_width gorp"
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.6 {GetBitmapData procedure} -setup {imageCleanup} -body {
image create bitmap -data "#define foo2_width 1.4"
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.7 {GetBitmapData procedure} -setup {imageCleanup} -body {
image create bitmap -data "#define foo2_height"
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.8 {GetBitmapData procedure} -setup {imageCleanup} -body {
image create bitmap -data "#define foo2_height gorp"
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.9 {GetBitmapData procedure} -setup {imageCleanup} -body {
image create bitmap -data "#define foo2_height 1.4"
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.10 {GetBitmapData procedure} -setup {imageCleanup} -body {
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]
} -cleanup {
image delete i1
} -result {15 14}
test imageBmap-5.11 {GetBitmapData procedure} -setup {imageCleanup} -body {
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]
} -cleanup {
image delete i1
} -result {15 14}
test imageBmap-5.12 {GetBitmapData procedure} -setup {imageCleanup} -body {
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};
}
} -returnCodes error -result {format error in bitmap data; looks like it's an obsolete X10 bitmap file}
test imageBmap-5.13 {GetBitmapData procedure} -setup {imageCleanup} -body {
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;
}
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.14 {GetBitmapData procedure} -setup {imageCleanup} -body {
image create bitmap i1 -data {
#define foo2_width 16
static char foo2_bits[] = {
0xff, 0xff, 0xff, }}
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.15 {GetBitmapData procedure} -setup {imageCleanup} -body {
image create bitmap i1 -data {
#define foo2_height 16
static char foo2_bits[] = {
0xff, 0xff, 0xff, }}
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.16 {GetBitmapData procedure} -setup {imageCleanup} -body {
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};
}
} -returnCodes error -result {format error in bitmap data}
test imageBmap-5.17 {GetBitmapData procedure} -setup {imageCleanup} -body {
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
"
} -returnCodes error -result {format error in bitmap data}
test imageBmap-6.1 {NextBitmapWord procedure} -setup {imageCleanup} -body {
image create bitmap i1 -data {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890}
} -returnCodes error -result {format error in bitmap data}
test imageBmap-6.2 {NextBitmapWord procedure} -setup {imageCleanup} -body {
makeFile {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890} foo3.bm
image create bitmap i1 -file foo3.bm
} -returnCodes error -result {format error in bitmap data}
test imageBmap-6.3 {NextBitmapWord procedure} -setup {imageCleanup} -body {
makeFile { } foo3.bm
image create bitmap i1 -file foo3.bm
} -returnCodes error -result {format error in bitmap data}
removeFile foo3.bm
imageCleanup
# Image used in 7.* tests
image create bitmap i1
test imageBmap-7.1 {ImgBmapCmd procedure} -body {
i1
} -returnCodes error -result {wrong # args: should be "i1 option ?arg ...?"}
test imageBmap-7.2 {ImgBmapCmd procedure, "cget" option} -body {
i1 cget
} -returnCodes error -result {wrong # args: should be "i1 cget option"}
test imageBmap-7.3 {ImgBmapCmd procedure, "cget" option} -body {
i1 cget a b
} -returnCodes error -result {wrong # args: should be "i1 cget option"}
test imageBmap-7.4 {ImgBmapCmd procedure, "cget" option} -body {
i1 co -foreground #123456
i1 cget -foreground
} -result {#123456}
test imageBmap-7.5 {ImgBmapCmd procedure, "cget" option} -body {
i1 cget -stupid
} -returnCodes error -result {unknown option "-stupid"}
test imageBmap-7.6 {ImgBmapCmd procedure} -body {
llength [i1 configure]
} -result {6}
test imageBmap-7.7 {ImgBmapCmd procedure} -body {
i1 co -foreground #001122
i1 configure -foreground
} -result {-foreground {} {} #000000 #001122}
test imageBmap-7.8 {ImgBmapCmd procedure} -body {
i1 configure -gorp
} -returnCodes error -result {unknown option "-gorp"}
test imageBmap-7.9 {ImgBmapCmd procedure} -body {
i1 configure -foreground #221100 -background
} -returnCodes error -result {value for "-background" missing}
test imageBmap-7.10 {ImgBmapCmd procedure} -body {
i1 gorp
} -returnCodes error -result {bad option "gorp": must be cget or configure}
test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} -setup {
destroy .c
pack [canvas .c]
update
} -body {
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
} -cleanup {
destroy .c
} -result {}
test imageBmap-9.1 {ImgBmapDisplay procedure, nothing to display} -setup {
destroy .c
pack [canvas .c]
update
} -body {
proc bgerror args {}
imageCleanup
image create bitmap i1 -data $data1
.c create image 50 100 -image i1 -tags i1.1
i1 configure -data {}
update
} -cleanup {
image delete i1
destroy .c
} -result {}
test imageBmap-9.2 {ImgBmapDisplay procedure, nothing to display} -setup {
destroy .c
pack [canvas .c]
update
} -body {
proc bgerror args {}
imageCleanup
.c delete all
image create bitmap i1 -data $data1
.c create image 50 100 -image i1 -tags i1.1
i1 configure -foreground bogus
update
} -cleanup {
image delete i1
destroy .c
} -result {}
if {[info exists bgerror]} {
rename bgerror {}
}
test imageBmap-10.1 {ImgBmapFree procedure, resource freeing} -setup {
destroy .c
pack [canvas .c]
update
} -body {
imageCleanup
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
} -cleanup {
destroy .c
} -result {}
test imageBmap-10.2 {ImgBmapFree procedures, unlinking} -setup {
destroy .c
pack [canvas .c]
update
} -body {
imageCleanup
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
} -cleanup {
image delete i1
deleteWindows
} -result {}
test imageBmap-11.1 {ImgBmapDelete procedure} -body {
image create bitmap i2 -file foo.bm -maskfile foo2.bm
image delete i2
info command i2
} -result {}
test imageBmap-11.2 {ImgBmapDelete procedure} -body {
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*]
} -result {{} newi2 foo.bm {}}
test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} -body {
image create bitmap i2 -file foo.bm -maskfile foo2.bm
rename i2 {}
list [lsearch -exact [imageNames] i2] [catch {i2 foo} msg] $msg
} -result {-1 1 {invalid command name "i2"}}
removeFile foo.bm
removeFile foo2.bm
imageFinish
# cleanup
cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:

1116
tests/imgPNG.test Normal file
View File

File diff suppressed because it is too large Load Diff

239
tests/imgPPM.test Normal file
View File

@@ -0,0 +1,239 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit
# Note that we do not use [tcltest::makeFile] because it is
# only suitable for text files
proc put {file data} {
set f [open $file w]
fconfigure $f -translation lf
puts -nonewline $f $data
close $f
}
test imgPPM-1.1 {FileReadPPM procedure} -body {
put test.ppm "P6\n0 256\n255\nabcdef"
image create photo p1 -file test.ppm
} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
test imgPPM-1.2 {FileReadPPM procedure} -body {
put test.ppm "P6\n-2 256\n255\nabcdef"
image create photo p1 -file test.ppm
} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
test imgPPM-1.3 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 0\n255\nabcdef"
image create photo p1 -file test.ppm
} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
test imgPPM-1.4 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 -2\n255\nabcdef"
image create photo p1 -file test.ppm
} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
test imgPPM-1.5 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 20\n100000\nabcdef"
image create photo p1 -file test.ppm
} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 100000}
test imgPPM-1.6 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 20\n0\nabcdef"
image create photo p1 -file test.ppm
} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 0}
test imgPPM-1.7 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 10\n255\nabcdef"
image create photo p1 -file test.ppm
} -returnCodes error -result {error reading PPM image file "test.ppm": not enough data}
test imgPPM-1.8 {FileReadPPM procedure} -body {
put test.ppm "P6\n5 4\n255\n01234567890123456789012345678901234567890123456789012345678"
image create photo p1 -file test.ppm
} -returnCodes error -result {error reading PPM image file "test.ppm": not enough data}
test imgPPM-1.9 {FileReadPPM procedure} -body {
put test.ppm "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789"
list [image create photo p1 -file test.ppm] \
[image width p1] [image height p1]
} -returnCodes ok -result {p1 5 4}
test imgPPM-2.1 {FileWritePPM procedure} -setup {
catch {image delete p1}
} -body {
put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
list [catch {p1 write not_a_dir/bar/baz/gorp} msg] [string tolower $msg] \
[string tolower $errorCode]
} -cleanup {
image delete p1
} -result {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} -setup {
catch {image delete p1}
catch {unset data}
} -body {
put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
p1 write -format ppm test.ppm
set fd [open test.ppm]
set data [read $fd]
close $fd
set data
} -cleanup {
image delete p1
} -result {P6
5 4
255
012345678901234567890123456789012345678901234567890123456789}
test imgPPM-3.1 {ReadPPMFileHeader procedure} -body {
put test.ppm "# \n#\n#\nP6\n#\n##\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
} -cleanup {
image delete p1
} -returnCodes ok -result p1
test imgPPM-3.2 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\n5\n 4 255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
} -cleanup {
image delete p1
} -returnCodes ok -result p1
test imgPPM-3.3 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\n# asdfasdf\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
} -cleanup {
image delete p1
} -returnCodes ok -result p1
test imgPPM-3.4 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6 \n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
} -cleanup {
image delete p1
} -returnCodes ok -result p1
test imgPPM-3.5 {ReadPPMFileHeader procedure} -body {
put test.ppm "P5\n5 4\n255\n01234567890123456789"
image create photo p1 -file test.ppm
} -cleanup {
image delete p1
} -returnCodes ok -result p1
test imgPPM-3.6 {ReadPPMFileHeader procedure} -body {
put test.ppm "P3\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
test imgPPM-3.7 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6x\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
test imgPPM-3.8 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\nxy5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
test imgPPM-3.9 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\n5\n255\n!012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
test imgPPM-3.10 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\n5 4\nzz255\n012345678901234567890123456789012345678901234567890123456789"
image create photo p1 -file test.ppm
} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
test imgPPM-3.11 {ReadPPMFileHeader procedure, empty file} -body {
put test.ppm " "
image create photo p1 -file test.ppm
} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
test imgPPM-3.12 {ReadPPMFileHeader procedure, file ends too soon} -body {
put test.ppm "P6\n566"
image create photo p1 -file test.ppm
} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} -body {
put test.ppm "P6\n566\n#asdf"
image create photo p1 -file test.ppm
} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
test imgPPM-4.1 {StringReadPPM procedure, data too short [Bug 1822391]} -body {
image create photo I -width 1103 -height 997
I put "P5\n1103 997\n255\n"
} -cleanup {
image delete I
} -returnCodes error -result {truncated PPM data}
test imgPPM-5.1 {StringReadPPM procedure} -setup {
image create photo ppm
} -body {
ppm put "P6\n0 256\n255\nabcdef"
} -returnCodes error -cleanup {
image delete ppm
} -result {PPM image data has dimension(s) <= 0}
test imgPPM-5.2 {StringReadPPM procedure} -setup {
image create photo ppm
} -body {
ppm put "P6\n-2 256\n255\nabcdef"
} -returnCodes error -cleanup {
image delete ppm
} -result {PPM image data has dimension(s) <= 0}
test imgPPM-5.3 {StringReadPPM procedure} -setup {
image create photo ppm
} -body {
ppm put "P6\n10 0\n255\nabcdef"
} -returnCodes error -cleanup {
image delete ppm
} -result {PPM image data has dimension(s) <= 0}
test imgPPM-5.4 {StringReadPPM procedure} -setup {
image create photo ppm
} -body {
ppm put "P6\n10 -2\n255\nabcdef"
} -returnCodes error -cleanup {
image delete ppm
} -result {PPM image data has dimension(s) <= 0}
test imgPPM-5.5 {StringReadPPM procedure} -setup {
image create photo ppm
} -body {
ppm put "P6\n10 20\n100000\nabcdef"
} -returnCodes error -cleanup {
image delete ppm
} -result {PPM image data has bad maximum intensity value 100000}
test imgPPM-5.6 {StringReadPPM procedure} -setup {
image create photo ppm
} -body {
ppm put "P6\n10 20\n0\nabcdef"
} -returnCodes error -cleanup {
image delete ppm
} -result {PPM image data has bad maximum intensity value 0}
test imgPPM-5.7 {StringReadPPM procedure} -setup {
image create photo ppm
} -body {
ppm put "P6\n10 10\n255\nabcdef"
} -returnCodes error -cleanup {
image delete ppm
} -result {truncated PPM data}
test imgPPM-5.8 {StringReadPPM procedure} -setup {
image create photo ppm
} -body {
ppm put "P6\n5 4\n255\n01234567890123456789012345678901234567890123456789012345678"
} -returnCodes error -cleanup {
image delete ppm
} -result {truncated PPM data}
test imgPPM-5.9 {StringReadPPM procedure} -setup {
image create photo ppm
} -body {
ppm put "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789"
list [image width ppm] [image height ppm]
} -cleanup {
image delete ppm
} -result {5 4}
imageFinish
# cleanup
catch {file delete test.ppm}
cleanupTests
return
# Local Variables:
# mode: tcl
# End:

1169
tests/imgPhoto.test Normal file
View File

File diff suppressed because it is too large Load Diff

40
tests/license.terms Normal file
View File

@@ -0,0 +1,40 @@
This software is copyrighted by the Regents of the University of
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
Corporation, Apple Inc. and other parties. The following terms apply to
all files associated with the software unless explicitly disclaimed in
individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file where
they apply.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.

3190
tests/listbox.test Normal file
View File

File diff suppressed because it is too large Load Diff

120
tests/main.test Normal file
View File

@@ -0,0 +1,120 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test main-1.1 {StdinProc} -constraints stdio -setup {
set script [makeFile {close stdin; exit} script]
} -body {
exec [interpreter] <$script
} -cleanup {
removeFile script
} -returnCodes ok
test main-2.1 {Tk_MainEx: -encoding option} -constraints stdio -setup {
set script [makeFile {} script]
file delete $script
set f [open $script w]
fconfigure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]; exit"
close $f
catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]}
} -body {
read $f
} -cleanup {
close $f
removeFile script
} -result "script {} 0\n1\n"
test main-2.2 {Tk_MainEx: -encoding option} -constraints stdio -setup {
set script [makeFile {} script]
file delete $script
set f [open $script w]
fconfigure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]; exit"
close $f
catch {set f [open "|[list [interpreter] -encoding ascii script]" r]}
} -body {
read $f
} -cleanup {
close $f
removeFile script
} -result "script {} 0\n0\n"
# Procedure to simulate interactive typing of commands, line by line,
# for test 2.3
proc type {chan script} {
foreach line [split $script \n] {
if {[catch {
puts $chan $line
flush $chan
}]} {
return
}
# Grrr... Behavior depends on this value.
after 1000
}
}
test main-2.3 {Tk_MainEx: -encoding option} -constraints stdio -setup {
set script [makeFile {} script]
file delete $script
set f [open $script w]
fconfigure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
close $f
catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]}
} -body {
type $f {
puts $argv
exit
}
gets $f
} -cleanup {
close $f
removeFile script
} -returnCodes ok -result {-enc utf-8 script}
test main-3.1 {Tk_ParseArgv: -help option} -constraints unix -body {
# Run only on unix as Win32 pops up native dialog
exec [interpreter] -help
} -returnCodes error -match glob -result {% application-specific initialization failed: Command-specific options:*}
test main-3.2 {Tk_ParseArgv: -help option} -setup {
set maininterp [interp create]
} -body {
$maininterp eval { set argc 1 ; set argv -help }
load {} Tk $maininterp
} -cleanup {
interp delete $maininterp
} -returnCodes error -match glob -result {Command-specific options:*}
test main-3.3 {Tk_ParseArgv: -help option} -setup {
set maininterp [interp create]
} -body {
# Repeat of 3.2 to catch cleanup, eg Bug 1927135
$maininterp eval { set argc 1 ; set argv -help }
load {} Tk $maininterp
} -cleanup {
interp delete $maininterp
} -returnCodes error -match glob -result {Command-specific options:*}
# cleanup
cleanupTests
return

3890
tests/menu.test Normal file
View File

File diff suppressed because it is too large Load Diff

717
tests/menuDraw.test Normal file
View File

@@ -0,0 +1,717 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
imageInit
test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup {
deleteWindows
} -body {
menu .m1
} -cleanup {
deleteWindows
} -result {.m1}
test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command
} -cleanup {
deleteWindows
} -result {}
test menuDraw-3.1 {TkMenuFreeDrawOptions} -setup {
deleteWindows
} -body {
menu .m1
destroy .m1
} -result {}
test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "This is a test"
destroy .m1
} -result {}
test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} -setup {
deleteWindows
} -body {
menu .m1
.m1 add checkbutton -label "This is a test." -font "Courier 12" \
-activeforeground red -background green -selectcolor purple
destroy .m1
} -result {}
test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} -setup {
deleteWindows
} -body {
menu .m1
} -cleanup {
deleteWindows
} -result {.m1}
test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} -setup {
deleteWindows
} -body {
menu .m1
.m1 configure -fg red
} -cleanup {
deleteWindows
} -result {}
test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} -setup {
deleteWindows
} -body {
menu .m1 -disabledforeground ""
} -cleanup {
deleteWindows
} -result {.m1}
test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo" -font "Courier 12"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo"
.m1 entryconfigure 1 -state active
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo"
.m1 activate 1
.m1 entryconfigure 1 -state active
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo"
.m1 activate 1
.m1 entryconfigure 1 -state normal
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo"
.m1 entryconfigure 1 -state foo
} -cleanup {
deleteWindows
} -returnCodes error -result {bad state "foo": must be active, normal, or disabled}
test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo" -font "Courier 12"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo" -background "red"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo" -foreground "red"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo" -activebackground "red"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo" -activeforeground "red"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} -setup {
deleteWindows
} -body {
menu .m1
.m1 add radiobutton -label "foo" -selectcolor "red"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo" -font "Helvetica 12"
.m1 entryconfigure 1 -font "Courier 12"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo" -activeforeground "red"
.m1 entryconfigure 1 -activeforeground "green"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} -setup {
deleteWindows
} -body {
menu .m1 -disabledforeground "red"
.m1 add command -label "foo"
.m1 configure -disabledforeground "green"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} -setup {
deleteWindows
} -body {
menu .m1
.m1 add radiobutton -label "foo" -selectcolor "red"
.m1 entryconfigure 1 -selectcolor "green"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-7.1 {TkEventuallyRecomputeMenu} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "This is a long label"
set tearoff [tk::TearOffMenu .m1]
update idletasks
.m1 entryconfigure 1 -label "foo"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "This is a long label"
set tearoff [tk::TearOffMenu .m1]
.m1 entryconfigure 1 -label "foo"
} -cleanup {
deleteWindows
} -result {}
test menuDraw-8.1 {TkRecomputeMenu} -constraints {
win userInteraction
} -setup {
deleteWindows
} -body {
menu .m1
.m1 configure -postcommand [.m1 add command -label foo]
.m1 add command -label "Hit ESCAPE to make this menu go away."
.m1 post 0 0
} -cleanup {
deleteWindows
} -result {}
test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} -setup {
deleteWindows
} -body {
catch {unset foo}
menu .m1
set foo 0
.m1 add radiobutton -variable foo -label test
tk::TearOffMenu .m1
update idletasks
list [set foo test] [destroy .m1] [unset foo]
} -result {test {} {}}
test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} -setup {
deleteWindows
} -body {
menu .m1
tk::TearOffMenu .m1
} -cleanup {
deleteWindows
} -returnCodes ok -match glob -result *
# Don't know how to test when window has been deleted and ComputeMenuGeometry
# gets called.
test menuDraw-10.1 {ComputeMenuGeometry - menubar} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label test
. configure -menu .m1
list [update idletasks] [. configure -menu ""]
} -cleanup {
deleteWindows
} -result {{} {}}
test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label test
update idletasks
} -cleanup {
deleteWindows
} -result {}
test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label test
update idletasks
} -cleanup {
deleteWindows
} -result {}
test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label test
update idletasks
.m1 entryconfigure 1 -label test
update idletasks
} -cleanup {
deleteWindows
} -result {}
test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} -constraints {
testImageType
} -setup {
deleteWindows
imageCleanup
} -body {
image create test image1
image create test image2
menu .m1
.m1 add checkbutton -image image1 -selectimage image2
.m1 invoke 1
set tearoff [tk::TearOffMenu .m1 40 40]
update idletasks
list [image delete image2] [destroy .m1]
} -cleanup {
imageCleanup
} -result {{} {}}
test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} -constraints {
testImageType
} -setup {
deleteWindows
imageCleanup
} -body {
image create test image1
image create test image2
menu .m1
.m1 add checkbutton -image image1 -selectimage image2
.m1 invoke 1
set tearoff [tk::TearOffMenu .m1 40 40]
list [image delete image2] [destroy .m1]
} -cleanup {
imageCleanup
} -result {{} {}}
test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} -constraints {
testImageType
} -setup {
deleteWindows
imageCleanup
} -body {
image create test image1
image create test image2
menu .m1
.m1 add checkbutton -image image1 -selectimage image2
set tearoff [tk::TearOffMenu .m1 40 40]
update idletasks
list [image delete image2] [destroy .m1]
} -cleanup {
imageCleanup
} -result {{} {}}
#Don't know how to test missing tkwin in DisplayMenu
test menuDraw-12.1 {DisplayMenu - menubar background} -constraints unix -setup {
deleteWindows
} -body {
menu .m1
.m1 add cascade -label foo -menu .m2
. configure -menu .m1
list [update] [. configure -menu ""]
} -cleanup {
deleteWindows
} -result {{} {}}
test menuDraw-12.2 {Display menu - no entries} -setup {
deleteWindows
} -body {
menu .m1
set tearoff [tk::TearOffMenu .m1 40 40]
update
} -cleanup {
deleteWindows
} -result {}
test menuDraw-12.3 {DisplayMenu - one entry} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
update
} -cleanup {
deleteWindows
} -result {}
test menuDraw-12.4 {DisplayMenu - two entries} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "one"
.m1 add command -label "two"
set tearoff [tk::TearOffMenu .m1 40 40]
update
} -cleanup {
deleteWindows
} -result {}
test menuDraw.12.5 {DisplayMenu - two columns - first bigger} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "one"
.m1 add command -label "two"
.m1 add command -label "three" -columnbreak 1
set tearoff [tk::TearOffMenu .m1 40 40]
update
} -cleanup {
deleteWindows
} -result {}
test menuDraw-12.5 {DisplayMenu - two column - second bigger} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "one"
.m1 add command -label "two" -columnbreak 1
.m1 add command -label "three"
set tearoff [tk::TearOffMenu .m1 40 40]
update
} -cleanup {
deleteWindows
} -result {}
test menuDraw.12.7 {DisplayMenu - three columns} -setup {
deleteWindows
} -body {
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 [tk::TearOffMenu .m1 40 40]
update
} -cleanup {
deleteWindows
} -result {}
test menuDraw-12.6 {Display menu - testing for extra space and menubars} -constraints {
unix
} -setup {
deleteWindows
} -body {
menu .m1
.m1 add cascade -label foo
. configure -menu .m1
update
. configure -menu ""
} -cleanup {
deleteWindows
} -result {}
test menuDraw-12.7 {Display menu - extra space at end of menu} -setup {
deleteWindows
} -body {
menu .m1
.m1 add cascade -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
wm geometry $tearoff 200x100
update
} -cleanup {
deleteWindows
} -result {}
test menuDraw-13.1 {TkMenuEventProc - Expose} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "one"
menu .m2
.m2 add command -label "two"
set tearoff1 [tk::TearOffMenu .m1 40 40]
set tearoff2 [tk::TearOffMenu .m2 40 40]
list [raise $tearoff2] [update]
} -cleanup {
deleteWindows
} -result {{} {}}
test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo"
set tearoff [tk::TearOffMenu .m1 40 40]
list [wm geometry $tearoff 200x100] [update]
} -cleanup {
deleteWindows
} -result {{} {}}
# 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} -setup {
deleteWindows
} -body {
menu .m1
destroy .m1
} -result {}
test menuDraw-13.5 {TkMenuEventProc - nothing pending} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label foo
update idletasks
destroy .m1
} -result {}
test menuDraw-14.1 {TkMenuImageProc} -constraints testImageType -setup {
deleteWindows
} -body {
catch {image delete image1}
menu .m1
image create test image1
.m1 add command -image image1
update idletasks
image delete image1
} -cleanup {
deleteWindows
} -result {}
test menuDraw-14.2 {TkMenuImageProc} -constraints testImageType -setup {
deleteWindows
} -body {
catch {image delete image1}
menu .m1
image create test image1
.m1 add command -image image1
image delete image1
} -cleanup {
deleteWindows
} -result {}
test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo"
tk::TearOffMenu .m1 40 40
} -cleanup {
deleteWindows
} -returnCodes ok -match glob -result *
test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo" -state active
set tearoff [tk::TearOffMenu .m1 40 40]
$tearoff index active
} -cleanup {
deleteWindows
} -result {none}
test menuDraw-15.3 {TkPostTearoffMenu - post command} -setup {
deleteWindows
} -body {
catch {unset foo}
menu .m1 -postcommand "set foo .m1"
.m1 add command -label "foo"
list [catch {tk::TearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1]
} -result {0 .m1 {} {}}
test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} -setup {
deleteWindows
} -body {
menu .m1 -postcommand "destroy .m1"
.m1 add command -label "foo"
list [catch {tk::TearOffMenu .m1 40 40} msg] $msg [winfo exists .m1]
} -result {0 {} 0}
test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo"
set height [winfo screenheight .m1]
tk::TearOffMenu .m1 40 $height
} -cleanup {
deleteWindows
} -returnCodes ok -match glob -result *
test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} -setup {
deleteWindows
} -body {
menu .m1
.m1 add command -label "foo"
set width [winfo screenwidth .m1]
tk::TearOffMenu .m1 $width 40
} -cleanup {
deleteWindows
} -returnCodes ok -match glob -result *
test menuDraw-16.1 {TkPostSubmenu} -constraints nonUnixUserInteraction -setup {
deleteWindows
} -body {
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 [tk::TearOffMenu .m1 40 40]
$tearoff postcascade 0
$tearoff postcascade 0
} -cleanup {
deleteWindows
} -result {}
test menuDraw-16.2 {TkPostSubMenu} -constraints nonUnixUserInteraction -setup {
deleteWindows
} -body {
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 [tk::TearOffMenu .m1 40 40]
$tearoff postcascade 0
$tearoff postcascade 1
} -cleanup {
deleteWindows
} -result {}
test menuDraw-16.3 {TkPostSubMenu} -setup {
deleteWindows
} -body {
menu .m1
.m1 add cascade -label test -menu .m2
.m1 postcascade 1
} -cleanup {
deleteWindows
} -result {}
test menuDraw-16.4 {TkPostSubMenu} -setup {
deleteWindows
} -body {
menu .m1
.m1 add cascade -label test
set tearoff [tk::TearOffMenu .m1 40 40]
$tearoff postcascade 0
} -cleanup {
deleteWindows
} -result {}
test menuDraw-16.5 {TkPostSubMenu} -constraints unix -setup {
deleteWindows
} -body {
menu .m1
.m1 add cascade -label test -menu .m2
menu .m2 -postcommand "glorp"
set tearoff [tk::TearOffMenu .m1 40 40]
$tearoff postcascade test
} -cleanup {
deleteWindows
} -returnCodes error -result {invalid command name "glorp"}
test menuDraw-16.6 {TkPostSubMenu} -constraints {
win userInteraction
} -setup {
deleteWindows
} -body {
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 [tk::TearOffMenu .m1 40 40]
$tearoff postcascade 0
} -cleanup {
deleteWindows
} -result {}
test menuDraw-17.1 {AdjustMenuCoords - menubar} -constraints unix -setup {
deleteWindows
} -body {
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 ""]
} -cleanup {
deleteWindows
} -result {{} {}}
test menuDraw-17.2 {AdjustMenuCoords - menu} -constraints {
win userInteraction
} -setup {
deleteWindows
} -body {
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 [tk::TearOffMenu .m1 40 40]
$tearoff postcascade 0
} -cleanup {
deleteWindows
} -result {}
# cleanup
imageFinish
deleteWindows
cleanupTests
return
# Local variables:
# mode: tcl
# End:

762
tests/menubut.test Normal file
View File

@@ -0,0 +1,762 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 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.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
imageInit
# 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}
menubutton .mb -text "Test"
pack .mb
update
test menubutton-1.1 {configuration options} -body {
.mb configure -activebackground #012345
.mb cget -activebackground
} -cleanup {
.mb configure -activebackground [lindex [.mb configure -activebackground] 3]
} -result {#012345}
test menubutton-1.2 {configuration options} -body {
.mb configure -activebackground non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test menubutton-1.3 {configuration options} -body {
.mb configure -activeforeground #ff0000
.mb cget -activeforeground
} -cleanup {
.mb configure -activeforeground [lindex [.mb configure -activeforeground] 3]
} -result {#ff0000}
test menubutton-1.4 {configuration options} -body {
.mb configure -activeforeground non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test menubutton-1.5 {configuration options} -body {
.mb configure -anchor nw
.mb cget -anchor
} -cleanup {
.mb configure -anchor [lindex [.mb configure -anchor] 3]
} -result {nw}
test menubutton-1.6 {configuration options} -body {
.mb configure -anchor bogus
} -returnCodes error -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
test menubutton-1.7 {configuration options} -body {
.mb configure -background #ff0000
.mb cget -background
} -cleanup {
.mb configure -background [lindex [.mb configure -background] 3]
} -result {#ff0000}
test menubutton-1.8 {configuration options} -body {
.mb configure -background non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test menubutton-1.9 {configuration options} -body {
.mb configure -bd 4
.mb cget -bd
} -cleanup {
.mb configure -bd [lindex [.mb configure -bd] 3]
} -result {4}
test menubutton-1.10 {configuration options} -body {
.mb configure -bd badValue
} -returnCodes error -result {bad screen distance "badValue"}
test menubutton-1.11 {configuration options} -body {
.mb configure -bg #ff0000
.mb cget -bg
} -cleanup {
.mb configure -bg [lindex [.mb configure -bg] 3]
} -result {#ff0000}
test menubutton-1.12 {configuration options} -body {
.mb configure -bg non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test menubutton-1.13 {configuration options} -body {
.mb configure -bitmap questhead
.mb cget -bitmap
} -cleanup {
.mb configure -bitmap [lindex [.mb configure -bitmap] 3]
} -result {questhead}
test menubutton-1.14 {configuration options} -body {
.mb configure -bitmap badValue
} -returnCodes error -result {bitmap "badValue" not defined}
test menubutton-1.15 {configuration options} -body {
.mb configure -borderwidth 1.3
.mb cget -borderwidth
} -cleanup {
.mb configure -borderwidth [lindex [.mb configure -borderwidth] 3]
} -result {1}
test menubutton-1.16 {configuration options} -body {
.mb configure -borderwidth badValue
} -returnCodes error -result {bad screen distance "badValue"}
test menubutton-1.17 {configuration options} -body {
.mb configure -cursor arrow
.mb cget -cursor
} -cleanup {
.mb configure -cursor [lindex [.mb configure -cursor] 3]
} -result {arrow}
test menubutton-1.18 {configuration options} -body {
.mb configure -cursor badValue
} -returnCodes error -result {bad cursor spec "badValue"}
test menubutton-1.19 {configuration options} -body {
.mb configure -direction below
.mb cget -direction
} -cleanup {
.mb configure -direction [lindex [.mb configure -direction] 3]
} -result {below}
test menubutton-1.20 {configuration options} -body {
.mb configure -direction badValue
} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right}
test menubutton-1.21 {configuration options} -body {
.mb configure -disabledforeground #00ff00
.mb cget -disabledforeground
} -cleanup {
.mb configure -disabledforeground [lindex [.mb configure -disabledforeground] 3]
} -result {#00ff00}
test menubutton-1.22 {configuration options} -body {
.mb configure -disabledforeground xyzzy
} -returnCodes error -result {unknown color name "xyzzy"}
test menubutton-1.23 {configuration options} -body {
.mb configure -fg #110022
.mb cget -fg
} -cleanup {
.mb configure -fg [lindex [.mb configure -fg] 3]
} -result {#110022}
test menubutton-1.24 {configuration options} -body {
.mb configure -fg bogus
} -returnCodes error -result {unknown color name "bogus"}
test menubutton-1.25 {configuration options} -body {
.mb configure -font {Helvetica 12}
.mb cget -font
} -cleanup {
.mb configure -font [lindex [.mb configure -font] 3]
} -result {Helvetica 12}
test menubutton-1.26 {configuration options} -body {
.mb configure -foreground #110022
.mb cget -foreground
} -cleanup {
.mb configure -foreground [lindex [.mb configure -foreground] 3]
} -result {#110022}
test menubutton-1.27 {configuration options} -body {
.mb configure -foreground bogus
} -returnCodes error -result {unknown color name "bogus"}
test menubutton-1.28 {configuration options} -body {
.mb configure -height 18
.mb cget -height
} -cleanup {
.mb configure -height [lindex [.mb configure -height] 3]
} -result {18}
test menubutton-1.29 {configuration options} -body {
.mb configure -height 20.0
} -returnCodes error -result {expected integer but got "20.0"}
test menubutton-1.30 {configuration options} -body {
.mb configure -highlightbackground #112233
.mb cget -highlightbackground
} -cleanup {
.mb configure -highlightbackground [lindex [.mb configure -highlightbackground] 3]
} -result {#112233}
test menubutton-1.31 {configuration options} -body {
.mb configure -highlightbackground ugly
} -returnCodes error -result {unknown color name "ugly"}
test menubutton-1.32 {configuration options} -body {
.mb configure -highlightcolor #110022
.mb cget -highlightcolor
} -cleanup {
.mb configure -highlightcolor [lindex [.mb configure -highlightcolor] 3]
} -result {#110022}
test menubutton-1.33 {configuration options} -body {
.mb configure -highlightcolor bogus
} -returnCodes error -result {unknown color name "bogus"}
test menubutton-1.34 {configuration options} -body {
.mb configure -highlightthickness 18
.mb cget -highlightthickness
} -cleanup {
.mb configure -highlightthickness [lindex [.mb configure -highlightthickness] 3]
} -result {18}
test menubutton-1.35 {configuration options} -body {
.mb configure -highlightthickness badValue
} -returnCodes error -result {bad screen distance "badValue"}
test menubutton-1.36 {configuration options} -constraints {
testImageType
} -setup {
catch {image delete image1}
image create test image1
} -body {
.mb configure -image image1
.mb cget -image
} -cleanup {
.mb configure -image [lindex [.mb configure -image] 3]
image create test image1
} -result {image1}
test menubutton-1.37 {configuration options} -setup {
catch {image delete bogus}
} -body {
.mb configure -image bogus
} -cleanup {
.mb configure -image [lindex [.mb configure -image] 3]
} -returnCodes error -result {image "bogus" doesn't exist}
test menubutton-1.38 {configuration options} -body {
.mb configure -indicatoron yes
.mb cget -indicatoron
} -cleanup {
.mb configure -indicatoron [lindex [.mb configure -indicatoron] 3]
} -result {1}
test menubutton-1.39 {configuration options} -body {
.mb configure -indicatoron no_way
} -returnCodes error -result {expected boolean value but got "no_way"}
test menubutton-1.40 {configuration options} -body {
.mb configure -justify right
.mb cget -justify
} -cleanup {
.mb configure -justify [lindex [.mb configure -justify] 3]
} -result {right}
test menubutton-1.41 {configuration options} -body {
.mb configure -justify bogus
} -returnCodes error -result {bad justification "bogus": must be left, right, or center}
test menubutton-1.42 {configuration options} -body {
.mb configure -menu {any old string}
.mb cget -menu
} -cleanup {
.mb configure -menu [lindex [.mb configure -menu] 3]
} -result {any old string}
test menubutton-1.43 {configuration options} -body {
.mb configure -padx 12
.mb cget -padx
} -cleanup {
.mb configure -padx [lindex [.mb configure -padx] 3]
} -result {12}
test menubutton-1.44 {configuration options} -body {
.mb configure -padx 420x
} -returnCodes error -result {bad screen distance "420x"}
test menubutton-1.45 {configuration options} -body {
.mb configure -pady 12
.mb cget -pady
} -cleanup {
.mb configure -pady [lindex [.mb configure -pady] 3]
} -result {12}
test menubutton-1.46 {configuration options} -body {
.mb configure -pady 420x
} -returnCodes error -result {bad screen distance "420x"}
test menubutton-1.47 {configuration options} -body {
.mb configure -relief groove
.mb cget -relief
} -cleanup {
.mb configure -relief [lindex [.mb configure -relief] 3]
} -result {groove}
test menubutton-1.48 {configuration options} -body {
.mb configure -relief 1.5
} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
test menubutton-1.49 {configuration options} -body {
.mb configure -state normal
.mb cget -state
} -cleanup {
.mb configure -state [lindex [.mb configure -state] 3]
} -result {normal}
test menubutton-1.50 {configuration options} -body {
.mb configure -state bogus
} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal}
test menubutton-1.51 {configuration options} -body {
.mb configure -takefocus {any string}
.mb cget -takefocus
} -cleanup {
.mb configure -takefocus [lindex [.mb configure -takefocus] 3]
} -result {any string}
test menubutton-1.52 {configuration options} -body {
.mb configure -text {Sample text}
.mb cget -text
} -cleanup {
.mb configure -text [lindex [.mb configure -text] 3]
} -result {Sample text}
test menubutton-1.53 {configuration options} -body {
.mb configure -textvariable i
.mb cget -textvariable
} -cleanup {
.mb configure -textvariable [lindex [.mb configure -textvariable] 3]
} -result {i}
test menubutton-1.54 {configuration options} -body {
.mb configure -underline 5
.mb cget -underline
} -cleanup {
.mb configure -underline [lindex [.mb configure -underline] 3]
} -result {5}
test menubutton-1.55 {configuration options} -body {
.mb configure -underline 3p
} -returnCodes error -result {expected integer but got "3p"}
test menubutton-1.56 {configuration options} -body {
.mb configure -width 402
.mb cget -width
} -cleanup {
.mb configure -width [lindex [.mb configure -width] 3]
} -result {402}
test menubutton-1.57 {configuration options} -body {
.mb configure -width 3p
} -returnCodes error -result {expected integer but got "3p"}
test menubutton-1.58 {configuration options} -body {
.mb configure -wraplength 100
.mb cget -wraplength
} -cleanup {
.mb configure -wraplength [lindex [.mb configure -wraplength] 3]
} -result {100}
test menubutton-1.59 {configuration options} -body {
.mb configure -wraplength 6x
} -returnCodes error -result {bad screen distance "6x"}
deleteWindows
menubutton .mb -text "Test"
pack .mb
update
test menubutton-2.1 {Tk_MenubuttonCmd procedure} -body {
menubutton
} -returnCodes error -result {wrong # args: should be "menubutton pathName ?-option value ...?"}
test menubutton-2.2 {Tk_MenubuttonCmd procedure} -body {
menubutton foo
} -returnCodes error -result {bad window path name "foo"}
test menubutton-2.3 {Tk_MenubuttonCmd procedure} -body {
catch {destroy .mb}
menubutton .mb
winfo class .mb
} -result {Menubutton}
test menubutton-2.4 {Tk_ButtonCmd procedure} -setup {
destroy .mb
} -body {
menubutton .mb -gorp foo
} -returnCodes error -result {unknown option "-gorp"}
test menubutton-2.5 {Tk_ButtonCmd procedure} -setup {
destroy .mb
} -body {
catch {menubutton .mb -gorp foo}
winfo exists .mb
} -result 0
deleteWindows
menubutton .mb -text "Test Menu"
pack .mb
test menubutton-3.1 {MenuButtonWidgetCmd procedure} -body {
.mb
} -returnCodes error -result {wrong # args: should be ".mb option ?arg ...?"}
test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} -body {
.mb c
} -returnCodes error -result {ambiguous option "c": must be cget or configure}
test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} -body {
.mb cget
} -returnCodes error -result {wrong # args: should be ".mb cget option"}
test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} -body {
.mb cget a b
} -returnCodes error -result {wrong # args: should be ".mb cget option"}
test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} -body {
.mb cget -gorp
} -returnCodes error -result {unknown option "-gorp"}
test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} -body {
.mb configure -highlightthickness 3
.mb cget -highlightthickness
} -result {3}
test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} -body {
llength [.mb configure]
} -result {33}
test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} -body {
.mb configure -gorp
} -returnCodes error -result {unknown option "-gorp"}
test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} -body {
.mb co -bg #ffffff -fg
} -returnCodes error -result {value for "-fg" missing}
test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} -body {
.mb configure -fg #123456
.mb configure -bg #654321
lindex [.mb configure -fg] 4
} -result {#123456}
test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} -body {
.mb foobar
} -returnCodes error -result {bad option "foobar": must be cget or configure}
deleteWindows
# 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} -setup {
deleteWindows
} -body {
button .mb1 -text "Menubutton 1"
.mb1 configure -width 1i
} -cleanup {
deleteWindows
} -returnCodes error -result {expected integer but got "1i"}
test menubutton-4.2 {ConfigureMenuButton procedure} -setup {
deleteWindows
} -body {
button .mb1 -text "Menubutton 1"
catch {.mb1 configure -width 1i}
return $errorInfo
} -cleanup {
deleteWindows
} -result {expected integer but got "1i"
(processing -width option)
invoked from within
".mb1 configure -width 1i"}
test menubutton-4.3 {ConfigureMenuButton procedure} -setup {
deleteWindows
} -body {
button .mb1 -text "Menubutton 1"
.mb1 configure -height 0.5c
} -cleanup {
deleteWindows
} -returnCodes error -result {expected integer but got "0.5c"}
test menubutton-4.4 {ConfigureMenuButton procedure} -setup {
deleteWindows
} -body {
button .mb1 -text "Menubutton 1"
catch {.mb1 configure -height 0.5c}
return $errorInfo
} -cleanup {
deleteWindows
} -result {expected integer but got "0.5c"
(processing -height option)
invoked from within
".mb1 configure -height 0.5c"}
test menubutton-4.5 {ConfigureMenuButton procedure} -setup {
deleteWindows
} -body {
button .mb1 -bitmap questhead
.mb1 configure -width abc
} -cleanup {
deleteWindows
} -returnCodes error -result {bad screen distance "abc"}
test menubutton-4.6 {ConfigureMenuButton procedure} -setup {
deleteWindows
} -body {
button .mb1 -bitmap questhead
catch {.mb1 configure -width abc}
return $errorInfo
} -cleanup {
deleteWindows
} -result {bad screen distance "abc"
(processing -width option)
invoked from within
".mb1 configure -width abc"}
test menubutton-4.7 {ConfigureMenuButton procedure} -constraints {
testImageType
} -setup {
deleteWindows
imageCleanup
} -body {
image create test image1
button .mb1 -image image1
.mb1 configure -height 0.5x
} -cleanup {
deleteWindows
imageCleanup
} -returnCodes error -result {bad screen distance "0.5x"}
test menubutton-4.8 {ConfigureMenuButton procedure} -constraints {
testImageType
} -setup {
deleteWindows
imageCleanup
} -body {
image create test image1
button .mb1 -image image1
catch {.mb1 configure -height 0.5x}
return $errorInfo
} -cleanup {
deleteWindows
imageCleanup
} -result {bad screen distance "0.5x"
(processing -height option)
invoked from within
".mb1 configure -height 0.5x"}
test menubutton-4.9 {ConfigureMenuButton procedure} -constraints {
nonPortable fonts
} -setup {
deleteWindows
} -body {
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]
} -cleanup {
deleteWindows
} -result {102 46 20 12}
test menubutton-4.10 {ConfigureMenuButton procedure - bad direction} -setup {
deleteWindows
} -body {
menubutton .mb -text "Test"
.mb configure -direction badValue
} -cleanup {
deleteWindows
} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right}
test menubutton-4.11 {ConfigureMenuButton procedure - bad direction} -setup {
deleteWindows
} -body {
menubutton .mb -text "Test"
catch {.mb configure -direction badValue}
list [.mb cget -direction] [destroy .mb]
} -cleanup {
deleteWindows
} -result {below {}}
# XXX Need to add tests for several procedures here. XXX
test menubutton-5.1 {MenuButtonEventProc procedure} -setup {
deleteWindows
set x {}
} -body {
menubutton .mb1 -bg #543210
rename .mb1 .mb2
lappend x [winfo children .]
lappend x [.mb2 cget -bg]
destroy .mb1
lappend x [info command .mb*] [winfo children .]
} -cleanup {
deleteWindows
} -result {.mb1 #543210 {} {}}
test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} -setup {
deleteWindows
} -body {
menubutton .mb1
rename .mb1 {}
list [info command .mb*] [winfo children .]
} -cleanup {
deleteWindows
} -result {{} {}}
test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints {
testImageType
} -setup {
deleteWindows
image create test image1
} -body {
menubutton .mb -image image1 -bd 4 -highlightthickness 0
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
imageCleanup
} -result {38 23}
test menubutton-7.2 {ComputeMenuButtonGeometry procedure} -constraints {
testImageType
} -setup {
deleteWindows
image create test image1
} -body {
menubutton .mb -image image1 -bd 1 -highlightthickness 2
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
imageCleanup
} -result {36 21}
test menubutton-7.3 {ComputeMenuButtonGeometry procedure} -constraints {
testImageType
} -setup {
deleteWindows
image create test image1
} -body {
menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
imageCleanup
} -result {34 19}
test menubutton-7.4 {ComputeMenuButtonGeometry procedure} -constraints {
testImageType
} -setup {
deleteWindows
image create test image1
} -body {
menubutton .mb -image image1 -bd 2 -relief raised -width 40 \
-highlightthickness 2
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
imageCleanup
} -result {48 23}
test menubutton-7.5 {ComputeMenuButtonGeometry procedure} -constraints {
testImageType
} -setup {
deleteWindows
image create test image1
} -body {
menubutton .mb -image image1 -bd 2 -relief raised -height 30 \
-highlightthickness 2
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
imageCleanup
} -result {38 38}
test menubutton-7.6 {ComputeMenuButtonGeometry procedure} -setup {
deleteWindows
} -body {
menubutton .mb -bitmap question -bd 2 -relief raised \
-highlightthickness 2
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
} -result {25 35}
test menubutton-7.7 {ComputeMenuButtonGeometry procedure} -setup {
deleteWindows
} -body {
menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \
-highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
} -result {46 33}
test menubutton-7.8 {ComputeMenuButtonGeometry procedure} -setup {
deleteWindows
} -body {
menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \
-highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
} -result {23 56}
test menubutton-7.9 {ComputeMenuButtonGeometry procedure} -constraints {
fonts
} -setup {
deleteWindows
} -body {
menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \
-highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
} -result {42 20}
test menubutton-7.10 {ComputeMenuButtonGeometry procedure} -constraints {
fonts
} -setup {
deleteWindows
} -body {
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]
} -cleanup {
deleteWindows
} -result {146 20}
test menubutton-7.11 {ComputeMenuButtonGeometry procedure} -constraints {
fonts
} -setup {
deleteWindows
} -body {
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]
} -cleanup {
deleteWindows
} -result {42 34}
test menubutton-7.12 {ComputeMenuButtonGeometry procedure} -constraints {
fonts
} -setup {
deleteWindows
} -body {
menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \
-highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
} -result {62 30}
test menubutton-7.13 {ComputeMenuButtonGeometry procedure} -constraints {
nonPortable fonts
} -setup {
deleteWindows
} -body {
menubutton .mb -text String -bd 2 -relief raised \
-highlightthickness 1 -indicatoron 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
} -result {78 28}
test menubutton-7.14 {ComputeMenuButtonGeometry procedure} -constraints {
testImageType unix nonPortable
} -setup {
deleteWindows
image create test image1
} -body {
# The following test is non-portable because the indicator's pixel
# size varies to maintain constant absolute size.
menubutton .mb -image image1 -bd 2 -relief raised \
-highlightthickness 2 -indicatoron 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
imageCleanup
} -result {64 23}
test menubutton-7.15 {ComputeMenuButtonGeometry procedure} -constraints {
testImageType win nonPortable
} -setup {
deleteWindows
image create test image1
} -body {
# The following test is non-portable because the indicator's pixel
# size varies to maintain constant absolute size.
menubutton .mb -image image1 -bd 2 -relief raised \
-highlightthickness 2 -indicatoron 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
} -cleanup {
deleteWindows
imageCleanup
} -result {65 23}
test menubutton-8.1 {menubutton vs hidden commands} -body {
set l [interp hidden]
deleteWindows
menubutton .mb
interp hide {} .mb
destroy .mb
set res1 [list [winfo children .] [interp hidden]]
set res2 [list {} $l]
expr {$res1 eq $res2}
} -result 1
deleteWindows
option clear
imageFinish
# cleanup
cleanupTests
return
# Local variables:
# mode: tcl
# End:

474
tests/message.test Normal file
View File

@@ -0,0 +1,474 @@
# This file is a Tcl script to test out the "message" 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.
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
tcltest::loadTestedCommands
eval tcltest::configure $argv
test message-1.1 {configuration option: "anchor"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -anchor w
.m cget -anchor
} -cleanup {
destroy .m
} -result {w}
test message-1.2 {configuration option: "anchor"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -anchor bogus
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
test message-1.3 {configuration option: "aspect"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -aspect 3
.m cget -aspect
} -cleanup {
destroy .m
} -result {3}
test message-1.4 {configuration option: "aspect"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -aspect bogus
} -cleanup {
destroy .m
} -returnCodes {error} -result {expected integer but got "bogus"}
test message-1.5 {configuration option: "background"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -background #ff0000
.m cget -background
} -cleanup {
destroy .m
} -result {#ff0000}
test message-1.6 {configuration option: "background"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -background non-existent
} -cleanup {
destroy .m
} -returnCodes {error} -result {unknown color name "non-existent"}
test message-1.7 {configuration option: "bd"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -bd 4
.m cget -bd
} -cleanup {
destroy .m
} -result {4}
test message-1.8 {configuration option: "bd"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -bd badValue
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad screen distance "badValue"}
test message-1.9 {configuration option: "bg"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -bg #ff0000
.m cget -bg
} -cleanup {
destroy .m
} -result {#ff0000}
test message-1.10 {configuration option: "bg"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -bg non-existent
} -cleanup {
destroy .m
} -returnCodes {error} -result {unknown color name "non-existent"}
test message-1.11 {configuration option: "borderwidth"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -borderwidth 1.3
.m cget -borderwidth
} -cleanup {
destroy .m
} -result {1}
test message-1.12 {configuration option: "borderwidth"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -borderwidth badValue
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad screen distance "badValue"}
test message-1.13 {configuration option: "cursor"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -cursor arrow
.m cget -cursor
} -cleanup {
destroy .m
} -result {arrow}
test message-1.14 {configuration option: "cursor"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -cursor badValue
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad cursor spec "badValue"}
test message-1.15 {configuration option: "fg"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -fg #00ff00
.m cget -fg
} -cleanup {
destroy .m
} -result {#00ff00}
test message-1.16 {configuration option: "fg"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -fg badValue
} -cleanup {
destroy .m
} -returnCodes {error} -result {unknown color name "badValue"}
test message-1.17 {configuration option: "font"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -font fixed
.m cget -font
} -cleanup {
destroy .m
} -result {fixed}
test message-1.18 {configuration option: "font"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -font {}
} -cleanup {
destroy .m
} -returnCodes {error} -result {font "" doesn't exist}
test message-1.19 {configuration option: "-foreground"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -foreground green
.m cget -foreground
} -cleanup {
destroy .m
} -result {green}
test message-1.20 {configuration option: "-foreground"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -foreground badValue
} -cleanup {
destroy .m
} -returnCodes {error} -result {unknown color name "badValue"}
test message-1.21 {configuration option: "highlightbackground"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -highlightbackground #112233
.m cget -highlightbackground
} -cleanup {
destroy .m
} -result {#112233}
test message-1.22 {configuration option: "highlightbackground"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -highlightbackground ugly
} -cleanup {
destroy .m
} -returnCodes {error} -result {unknown color name "ugly"}
test message-1.23 {configuration option: "highlightcolor"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -highlightcolor #123456
.m cget -highlightcolor
} -cleanup {
destroy .m
} -result {#123456}
test message-1.24 {configuration option: "highlightcolor"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -highlightcolor non-existent
} -cleanup {
destroy .m
} -returnCodes {error} -result {unknown color name "non-existent"}
test message-1.25 {configuration option: "highlightthickness"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -highlightthickness 2
.m cget -highlightthickness
} -cleanup {
destroy .m
} -result {2}
test message-1.26 {configuration option: "highlightthickness"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -highlightthickness badValue
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad screen distance "badValue"}
test message-1.27 {configuration option: "justify"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -justify right
.m cget -justify
} -cleanup {
destroy .m
} -result {right}
test message-1.28 {configuration option: "justify"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -justify bogus
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
test message-1.29 {configuration option: "padx"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -padx 12m
.m cget -padx
} -cleanup {
destroy .m
} -result {12m}
test message-1.30 {configuration option: "padx"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -padx 420x
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad screen distance "420x"}
test message-1.31 {configuration option: "pady"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -pady 12m
.m cget -pady
} -cleanup {
destroy .m
} -result {12m}
test message-1.32 {configuration option: "pady"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -pady 420x
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad screen distance "420x"}
test message-1.33 {configuration option: "relief"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -relief ridge
.m cget -relief
} -cleanup {
destroy .m
} -result {ridge}
test message-1.34 {configuration option: "relief"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -relief badValue
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
test message-1.35 {configuration options: "text"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -text "Sample text"
.m cget -text
} -cleanup {
destroy .m
} -result {Sample text}
test message-1.36 {configuration option: "textvariable"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -textvariable i
.m cget -textvariable
} -cleanup {
destroy .m
} -result {i}
test message-1.37 {configuration option: "width"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -width 2
.m cget -width
} -cleanup {
destroy .m
} -result {2}
test message-1.38 {configuration option: "width"} -setup {
message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
pack .m
update
} -body {
.m configure -width badValue
} -cleanup {
destroy .m
} -returnCodes {error} -result {bad screen distance "badValue"}
test message-2.1 {Tk_MessageObjCmd procedure} -body {
message
} -returnCodes {error} -result {wrong # args: should be "message pathName ?-option value ...?"}
test message-2.2 {Tk_MessageObjCmd procedure} -body {
message foo
} -returnCodes {error} -result {bad window path name "foo"}
test message-2.3 {Tk_MessageObjCmd procedure} -body {
catch {message foo}
winfo child .
} -result {}
test message-2.4 {Tk_MessageObjCmd procedure} -body {
message .s -gorp dump
} -returnCodes {error} -result {unknown option "-gorp"}
test message-2.5 {Tk_MessageObjCmd procedure} -body {
catch {message .s -gorp dump}
winfo child .
} -result {}
test message-3.1 {MessageWidgetObjCmd procedure} -setup {
message .m
} -body {
.m
} -cleanup {
destroy .m
} -returnCodes error -result {wrong # args: should be ".m option ?arg ...?"}
test message-3.2 {MessageWidgetObjCmd procedure, "cget"} -setup {
message .m
} -body {
.m cget
} -cleanup {
destroy .m
} -returnCodes error -result {wrong # args: should be ".m cget option"}
test message-3.3 {MessageWidgetObjCmd procedure, "cget"} -setup {
message .m
} -body {
.m cget -gorp
} -cleanup {
destroy .m
} -returnCodes error -result {unknown option "-gorp"}
test message-3.4 {MessageWidgetObjCmd procedure, "configure"} -setup {
message .m
} -body {
.m configure -text foobar
lindex [.m configure -text] 4
} -cleanup {
destroy .m
} -result {foobar}
test message-3.5 {MessageWidgetObjCmd procedure, "configure"} -setup {
message .m
} -body {
llength [.m configure]
} -cleanup {
destroy .m
} -result {21}
test message-3.6 {MessageWidgetObjCmd procedure, "configure"} -setup {
message .m
} -body {
.m configure -foo
} -cleanup {
destroy .m
} -returnCodes error -result {unknown option "-foo"}
test message-3.7 {MessageWidgetObjCmd procedure, "configure"} -setup {
message .m
} -body {
.m configure -bd 4
.m configure -bg #ffffff
lindex [.m configure -bd] 4
} -cleanup {
destroy .m
} -result {4}
cleanupTests
return

449
tests/msgbox.test Normal file
View File

@@ -0,0 +1,449 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
test msgbox-1.1 {tk_messageBox command} -body {
tk_messageBox -foo
} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
test msgbox-1.2 {tk_messageBox command} -body {
tk_messageBox -foo bar
} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
test msgbox-1.3 {tk_messageBox command} -body {
tk_messageBox -default
} -returnCodes error -result {value for "-default" missing}
test msgbox-1.4 {tk_messageBox command} -body {
tk_messageBox -detail
} -returnCodes error -result {value for "-detail" missing}
test msgbox-1.5 {tk_messageBox command} -body {
tk_messageBox -icon
} -returnCodes error -result {value for "-icon" missing}
test msgbox-1.6 {tk_messageBox command} -body {
tk_messageBox -message
} -returnCodes error -result {value for "-message" missing}
test msgbox-1.7 {tk_messageBox command} -body {
tk_messageBox -parent
} -returnCodes error -result {value for "-parent" missing}
test msgbox-1.8 {tk_messageBox command} -body {
tk_messageBox -title
} -returnCodes error -result {value for "-title" missing}
test msgbox-1.9 {tk_messageBox command} -body {
tk_messageBox -type
} -returnCodes error -result {value for "-type" missing}
test msgbox-1.10 {tk_messageBox command} -body {
tk_messageBox -default
} -returnCodes error -result {value for "-default" missing}
test msgbox-1.11 {tk_messageBox command} -body {
tk_messageBox -type foo
} -returnCodes error -result {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}
test msgbox-1.12 {tk_messageBox command} -constraints unix -body {
tk_messageBox -default 1.1
} -returnCodes error -result {invalid default button "1.1"}
test msgbox-1.13 {tk_messageBox command} -constraints macOrWin -body {
tk_messageBox -default 1.1
} -returnCodes error -result {bad -default value "1.1": must be abort, retry, ignore, ok, cancel, no, or yes}
test msgbox-1.14 {tk_messageBox command} -constraints unix -body {
tk_messageBox -default foo
} -returnCodes error -result {invalid default button "foo"}
test msgbox-1.15 {tk_messageBox command} -constraints macOrWin -body {
tk_messageBox -default foo
} -returnCodes error -result {bad -default value "foo": must be abort, retry, ignore, ok, cancel, no, or yes}
test msgbox-1.16 {tk_messageBox command} -constraints unix -body {
tk_messageBox -type yesno -default 3
} -returnCodes error -result {invalid default button "3"}
test msgbox-1.17 {tk_messageBox command} -constraints macOrWin -body {
tk_messageBox -type yesno -default 3
} -returnCodes error -result {bad -default value "3": must be abort, retry, ignore, ok, cancel, no, or yes}
test msgbox-1.18 {tk_messageBox command} -body {
tk_messageBox -icon foo
} -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning}
test msgbox-1.19 {tk_messageBox command} -body {
tk_messageBox -parent foo.bar
} -returnCodes error -result {bad window path name "foo.bar"}
catch {tk_messageBox -foo bar}
set isNative [expr {[info commands tk::MessageBox] == ""}]
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
}
}
#
# Try out all combinations of (type) x (default button) and
# (type) x (icon).
#
test msgbox-2.1 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . abort
tk_messageBox -title Hi -message "Please press abort" -type abortretryignore
} -result {abort}
test msgbox-2.2 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . abort
tk_messageBox -title Hi -message "Please press abort" \
-type abortretryignore -icon warning
} -result {abort}
test msgbox-2.3 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . abort
tk_messageBox -title Hi -message "Please press abort" \
-type abortretryignore -icon error
} -result {abort}
test msgbox-2.4 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . abort
tk_messageBox -title Hi -message "Please press abort" \
-type abortretryignore -icon info
} -result {abort}
test msgbox-2.5 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . abort
tk_messageBox -title Hi -message "Please press abort" \
-type abortretryignore -icon question
} -result {abort}
test msgbox-2.6 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . abort
tk_messageBox -title Hi -message "Please press abort" \
-type abortretryignore -default abort
} -result {abort}
test msgbox-2.7 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . retry
tk_messageBox -title Hi -message "Please press retry" \
-type abortretryignore -default retry
} -result {retry}
test msgbox-2.8 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ignore
tk_messageBox -title Hi -message "Please press ignore" \
-type abortretryignore -default ignore
} -result {ignore}
test msgbox-2.9 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" -type ok
} -result {ok}
test msgbox-2.10 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type ok -icon warning
} -result {ok}
test msgbox-2.11 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type ok -icon error
} -result {ok}
test msgbox-2.12 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type ok -icon info
} -result {ok}
test msgbox-2.13 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type ok -icon question
} -result {ok}
test msgbox-2.14 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type ok -default ok
} -result {ok}
test msgbox-2.15 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" -type okcancel
} -result {ok}
test msgbox-2.16 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type okcancel -icon warning
} -result {ok}
test msgbox-2.17 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type okcancel -icon error
} -result {ok}
test msgbox-2.18 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type okcancel -icon info
} -result {ok}
test msgbox-2.19 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type okcancel -icon question
} -result {ok}
test msgbox-2.20 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . ok
tk_messageBox -title Hi -message "Please press ok" \
-type okcancel -default ok
} -result {ok}
test msgbox-2.21 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . cancel
tk_messageBox -title Hi -message "Please press cancel" \
-type okcancel -default cancel
} -result {cancel}
test msgbox-2.22 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . retry
tk_messageBox -title Hi -message "Please press retry" -type retrycancel
} -result {retry}
test msgbox-2.23 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . retry
tk_messageBox -title Hi -message "Please press retry" \
-type retrycancel -icon warning
} -result {retry}
test msgbox-2.24 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . retry
tk_messageBox -title Hi -message "Please press retry" \
-type retrycancel -icon error
} -result {retry}
test msgbox-2.25 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . retry
tk_messageBox -title Hi -message "Please press retry" \
-type retrycancel -icon info
} -result {retry}
test msgbox-2.26 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . retry
tk_messageBox -title Hi -message "Please press retry" \
-type retrycancel -icon question
} -result {retry}
test msgbox-2.27 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . retry
tk_messageBox -title Hi -message "Please press retry" \
-type retrycancel -default retry
} -result {retry}
test msgbox-2.28 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . cancel
tk_messageBox -title Hi -message "Please press cancel" \
-type retrycancel -default cancel
} -result {cancel}
test msgbox-2.29 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" -type yesno
} -result {yes}
test msgbox-2.30 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesno -icon warning
} -result {yes}
test msgbox-2.31 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesno -icon error
} -result {yes}
test msgbox-2.32 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesno -icon info
} -result {yes}
test msgbox-2.33 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesno -icon question
} -result {yes}
test msgbox-2.34 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesno -default yes
} -result {yes}
test msgbox-2.35 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . no
tk_messageBox -title Hi -message "Please press no" \
-type yesno -default no
} -result {no}
test msgbox-2.36 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" -type yesnocancel
} -result {yes}
test msgbox-2.37 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesnocancel -icon warning
} -result {yes}
test msgbox-2.38 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesnocancel -icon error
} -result {yes}
test msgbox-2.39 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesnocancel -icon info
} -result {yes}
test msgbox-2.40 {tk_messageBox command -icon option} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesnocancel -icon question
} -result {yes}
test msgbox-2.41 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . yes
tk_messageBox -title Hi -message "Please press yes" \
-type yesnocancel -default yes
} -result {yes}
test msgbox-2.42 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . no
tk_messageBox -title Hi -message "Please press no" \
-type yesnocancel -default no
} -result {no}
test msgbox-2.43 {tk_messageBox command} -constraints {
nonUnixUserInteraction
} -body {
ChooseMsg . cancel
tk_messageBox -title Hi -message "Please press cancel" \
-type yesnocancel -default cancel
} -result {cancel}
# These tests will hang your test suite if they fail.
test msgbox-3.1 {tk_messageBox handles withdrawn parent} -constraints {
nonUnixUserInteraction
} -body {
wm withdraw .
ChooseMsg . "ok"
tk_messageBox -title Hi -message "Please press ok" \
-type ok -default ok
} -cleanup {
wm deiconify .
} -result {ok}
test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints {
nonUnixUserInteraction
} -body {
wm iconify .
ChooseMsg . "ok"
tk_messageBox -title Hi -message "Please press ok" \
-type ok -default ok
} -cleanup {
wm deiconify .
} -result {ok}
# cleanup
cleanupTests
return

28
tests/obj.test Normal file
View File

@@ -0,0 +1,28 @@
# This file is a Tcl script to test new object types in Tk.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test obj-1.1 {TkGetPixelsFromObj} -body {
} -result {}
test obj-2.1 {FreePixelInternalRep} -body {
} -result {}
test obj-3.1 {DupPixelInternalRep} -body {
} -result {}
test obj-4.1 {SetPixelFromAny} -body {
} -result {}
# cleanup
cleanupTests
return

552
tests/oldpack.test Normal file
View File

@@ -0,0 +1,552 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
# First, test a single window packed in various ways in a parent
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 oldpack-1.1 {basic positioning} -body {
pack ap .pack .pack.red top
update
winfo geometry .pack.red
} -result 10x20+45+0
test oldpack-1.2 {basic positioning} -body {
pack append .pack .pack.red bottom
update
winfo geometry .pack.red
} -result 10x20+45+80
test oldpack-1.3 {basic positioning} -body {
pack append .pack .pack.red left
update
winfo geometry .pack.red
} -result 10x20+0+40
test oldpack-1.4 {basic positioning} -body {
pack append .pack .pack.red right
update
winfo geometry .pack.red
} -result 10x20+90+40
# Try adding padding around the window and make sure that the
# window gets a larger frame.
test oldpack-2.1 {padding} -body {
pack append .pack .pack.red {t padx 20}
update
winfo geometry .pack.red
} -result 10x20+45+0
test oldpack-2.2 {padding} -body {
pack append .pack .pack.red {top pady 20}
update
winfo geometry .pack.red
} -result 10x20+45+10
test oldpack-2.3 {padding} -body {
pack append .pack .pack.red {l padx 20}
update
winfo geometry .pack.red
} -result 10x20+10+40
test oldpack-2.4 {padding} -body {
pack append .pack .pack.red {left pady 20}
update
winfo geometry .pack.red
} -result 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 oldpack-3.1 {framing} -body {
pack append .pack .pack.red {b padx 20 pady 30}
update
winfo geometry .pack.red
} -result 10x20+45+65
test oldpack-3.2 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 fr n}
update
winfo geometry .pack.red
} -result 10x20+45+50
test oldpack-3.3 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame ne}
update
winfo geometry .pack.red
} -result 10x20+90+50
test oldpack-3.4 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame e}
update
winfo geometry .pack.red
} -result 10x20+90+65
test oldpack-3.5 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame se}
update
winfo geometry .pack.red
} -result 10x20+90+80
test oldpack-3.6 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame s}
update
winfo geometry .pack.red
} -result 10x20+45+80
test oldpack-3.7 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame sw}
update
winfo geometry .pack.red
} -result 10x20+0+80
test oldpack-3.8 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame w}
update
winfo geometry .pack.red
} -result 10x20+0+65
test oldpack-3.9 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame nw}
update
winfo geometry .pack.red
} -result 10x20+0+50
test oldpack-3.10 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame c}
update
winfo geometry .pack.red
} -result 10x20+45+65
test oldpack-3.11 {framing} -body {
pack append .pack .pack.red {r padx 20 pady 30}
update
winfo geometry .pack.red
} -result 10x20+80+40
test oldpack-3.12 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame n}
update
winfo geometry .pack.red
} -result 10x20+80+0
test oldpack-3.13 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame ne}
update
winfo geometry .pack.red
} -result 10x20+90+0
test oldpack-3.14 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame e}
update
winfo geometry .pack.red
} -result 10x20+90+40
test oldpack-3.15 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame se}
update
winfo geometry .pack.red
} -result 10x20+90+80
test oldpack-3.16 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame s}
update
winfo geometry .pack.red
} -result 10x20+80+80
test oldpack-3.17 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame sw}
update
winfo geometry .pack.red
} -result 10x20+70+80
test oldpack-3.18 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame w}
update
winfo geometry .pack.red
} -result 10x20+70+40
test oldpack-3.19 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame nw}
update
winfo geometry .pack.red
} -result 10x20+70+0
test oldpack-3.20 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame center}
update
winfo geometry .pack.red
} -result 10x20+80+40
# Try out various filling combinations in a couple of different
# frame locations.
test oldpack-4.1 {filling} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 fillx}
update
winfo geometry .pack.red
} -result 100x20+0+65
test oldpack-4.2 {filling} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 filly}
update
winfo geometry .pack.red
} -result 10x50+45+50
test oldpack-4.3 {filling} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 fill}
update
winfo geometry .pack.red
} -result 100x50+0+50
test oldpack-4.4 {filling} -body {
pack append .pack .pack.red {right padx 20 pady 30 fillx}
update
winfo geometry .pack.red
} -result 30x20+70+40
test oldpack-4.5 {filling} -body {
pack append .pack .pack.red {right padx 20 pady 30 filly}
update
winfo geometry .pack.red
} -result 10x100+80+0
test oldpack-4.6 {filling} -body {
pack append .pack .pack.red {right padx 20 pady 30 fill}
update
winfo geometry .pack.red
} -result 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 oldpack-5.1 {multiple windows} -body {
winfo geometry .pack.red
} -result 10x20+45+0
test oldpack-5.2 {multiple windows} -body {
winfo geometry .pack.green
} -result 30x40+35+20
test oldpack-5.3 {multiple windows} -body {
winfo geometry .pack.blue
} -result 40x40+30+60
test oldpack-5.4 {multiple windows} -body {
winfo ismapped .pack.violet
} -result 0
pack b .pack.blue .pack.violet top
update
test oldpack-5.5 {multiple windows} -body {
winfo ismapped .pack.violet
} -result 1
test oldpack-5.6 {multiple windows} -body {
winfo geometry .pack.violet
} -result 80x20+10+60
test oldpack-5.7 {multiple windows} -body {
winfo geometry .pack.blue
} -result 40x20+30+80
pack after .pack.blue .pack.red top
update
test oldpack-5.8 {multiple windows} -body {
winfo geometry .pack.green
} -result 30x40+35+0
test oldpack-5.9 {multiple windows} -body {
winfo geometry .pack.violet
} -result 80x20+10+40
test oldpack-5.10 {multiple windows} -body {
winfo geometry .pack.blue
} -result 40x40+30+60
test oldpack-5.11 {multiple windows} -body {
winfo ismapped .pack.red
} -result 0
pack before .pack.green .pack.red right .pack.blue left
update
test oldpack-5.12 {multiple windows} -body {
winfo ismapped .pack.red
} -result 1
test oldpack-5.13 {multiple windows} -body {
winfo geometry .pack.red
} -result 10x20+90+40
test oldpack-5.14 {multiple windows} -body {
winfo geometry .pack.blue
} -result 40x40+0+30
test oldpack-5.15 {multiple windows} -body {
winfo geometry .pack.green
} -result 30x40+50+0
test oldpack-5.16 {multiple windows} -body {
winfo geometry .pack.violet
} -result 50x20+40+40
pack append .pack .pack.violet left .pack.green bottom .pack.red bottom \
.pack.blue bottom
update
test oldpack-5.17 {multiple windows} -body {
winfo geometry .pack.violet
} -result 80x20+0+40
test oldpack-5.18 {multiple windows} -body {
winfo geometry .pack.green
} -result 20x40+80+60
test oldpack-5.19 {multiple windows} -body {
winfo geometry .pack.red
} -result 10x20+85+40
test oldpack-5.20 {multiple windows} -body {
winfo geometry .pack.blue
} -result 20x40+80+0
pack after .pack.blue .pack.blue top .pack.red right .pack.green right \
.pack.violet right
update
test oldpack-5.21 {multiple windows} -body {
winfo geometry .pack.blue
} -result 40x40+30+0
test oldpack-5.22 {multiple windows} -body {
winfo geometry .pack.red
} -result 10x20+90+60
test oldpack-5.23 {multiple windows} -body {
winfo geometry .pack.green
} -result 30x40+60+50
test oldpack-5.24 {multiple windows} -body {
winfo geometry .pack.violet
} -result 60x20+0+60
pack after .pack.blue .pack.red left .pack.green left .pack.violet left
update
test oldpack-5.25 {multiple windows} -body {
winfo geometry .pack.blue
} -result 40x40+30+0
test oldpack-5.26 {multiple windows} -body {
winfo geometry .pack.red
} -result 10x20+0+60
test oldpack-5.27 {multiple windows} -body {
winfo geometry .pack.green
} -result 30x40+10+50
test oldpack-5.28 {multiple windows} -body {
winfo geometry .pack.violet
} -result 60x20+40+60
pack append .pack .pack.violet left .pack.green left .pack.blue left \
.pack.red left
update
test oldpack-5.29 {multiple windows} -body {
winfo geometry .pack.violet
} -result 80x20+0+40
test oldpack-5.30 {multiple windows} -body {
winfo geometry .pack.green
} -result 20x40+80+30
test oldpack-5.31 {multiple windows} -body {
winfo ismapped .pack.blue
} -result 0
test oldpack-5.32 {multiple windows} -body {
winfo ismapped .pack.red
} -result 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 oldpack-6.1 {geometry propagation} -body {
winfo reqwidth .pack} -result 80
test oldpack-6.2 {geometry propagation} -body {
winfo reqheight .pack} -result 120
destroy .pack.violet
update
test oldpack-6.3 {geometry propagation} -body {
winfo reqwidth .pack} -result 40
test oldpack-6.4 {geometry propagation} -body {
winfo reqheight .pack} -result 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 oldpack-6.5 {geometry propagation} -body {
winfo reqwidth .pack} -result 120
test oldpack-6.6 {geometry propagation} -body {
winfo reqheight .pack} -result 60
pack append .pack .pack.violet top .pack.green top .pack.blue left \
.pack.red left
update
test oldpack-6.7 {geometry propagation} -body {
winfo reqwidth .pack} -result 80
test oldpack-6.8 {geometry propagation} -body {
winfo reqheight .pack} -result 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 oldpack-7.1 {multiple expanded windows} -body {
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]
} -result {30x40+3+40 40x40+39+40 10x20+86+50}
test oldpack-7.2 {multiple expanded windows} -body {
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]
} -result {70x20+30+77 40x40+45+30 10x20+60+3}
test oldpack-7.3 {multiple expanded windows} -body {
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]
} -result {40x100+0+0 20x100+40+0 40x40+60+0}
test oldpack-7.4 {multiple expanded windows} -body {
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]
} -result {10x20+45+5 80x20+10+35 40x40+60+60}
test oldpack-7.5 {multiple expanded windows} -body {
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]
} -result {30x40+70+60 10x20+30+40}
test oldpack-7.6 {multiple expanded windows} -body {
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]
} -result {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 oldpack-8.1 {syntax errors} -body {
pack
} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
test oldpack-8.2 {syntax errors} -body {
pack append
} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
test oldpack-8.3 {syntax errors} -body {
pack gorp foo
} -returnCodes error -result {bad option "gorp": must be configure, forget, info, propagate, or slaves}
test oldpack-8.4 {syntax errors} -body {
pack a .pack
} -returnCodes error -result {bad option "a": must be configure, forget, info, propagate, or slaves}
test oldpack-8.5 {syntax errors} -body {
pack after foobar
} -returnCodes error -result {bad window path name "foobar"}
test oldpack-8.6 {syntax errors} -setup {
destroy .pack.yellow
} -body {
frame .pack.yellow -bg yellow
pack after .pack.yellow
} -cleanup {
destroy .pack.yellow
} -returnCodes error -result {window ".pack.yellow" isn't packed}
test oldpack-8.7 {syntax errors} -body {
pack append foobar
} -returnCodes error -result {bad window path name "foobar"}
test oldpack-8.8 {syntax errors} -body {
pack before foobar
} -returnCodes error -result {bad window path name "foobar"}
test oldpack-8.9 {syntax errors} -setup {
destroy .pack.yellow
} -body {
frame .pack.yellow -bg yellow
pack before .pack.yellow
} -cleanup {
destroy .pack.yellow
} -returnCodes error -result {window ".pack.yellow" isn't packed}
test oldpack-8.10 {syntax errors} -body {
pack info .pack help
} -returnCodes error -result {wrong # args: should be "pack info window"}
test oldpack-8.11 {syntax errors} -body {
pack info foobar
} -returnCodes error -result {bad window path name "foobar"}
test oldpack-8.12 {syntax errors} -body {
pack append .pack .pack.blue
} -returnCodes error -result {wrong # args: window ".pack.blue" should be followed by options}
test oldpack-8.13 {syntax errors} -body {
pack append . .pack.blue top
} -returnCodes error -result {can't pack .pack.blue inside .}
test oldpack-8.14 {syntax errors} -body {
pack append .pack .pack.blue f
} -returnCodes error -result {bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
test oldpack-8.15 {syntax errors} -body {
pack append .pack .pack.blue pad
} -returnCodes error -result {bad option "pad": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
test oldpack-8.16 {syntax errors} -body {
pack append .pack .pack.blue {frame south}
} -returnCodes error -result {bad anchor "south": must be n, ne, e, se, s, sw, w, nw, or center}
test oldpack-8.17 {syntax errors} -body {
pack append .pack .pack.blue {padx -2}
} -returnCodes error -result {bad pad value "-2": must be positive screen distance}
test oldpack-8.18 {syntax errors} -body {
pack append .pack .pack.blue {padx}
} -returnCodes error -result {wrong # args: "padx" option must be followed by screen distance}
test oldpack-8.19 {syntax errors} -body {
pack append .pack .pack.blue {pady -2}
} -returnCodes error -result {bad pad value "-2": must be positive screen distance}
test oldpack-8.20 {syntax errors} -body {
pack append .pack .pack.blue {pady}
} -returnCodes error -result {wrong # args: "pady" option must be followed by screen distance}
test oldpack-8.21 {syntax errors} -body {
pack append .pack .pack.blue "\{abc"
} -returnCodes error -result {unmatched open brace in list}
test oldpack-8.22 {syntax errors} -body {
pack append .pack .pack.blue frame
} -returnCodes error -result {wrong # args: "frame" option must be followed by anchor point}
# Test "pack info" command output.
test oldpack-9.1 {information output} -body {
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]
} -result {{.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 oldpack-9.2 {information output} -body {
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]
} -result {{.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 oldpack-9.3 {information output} -body {
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]
} -result {{.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}}
destroy .pack
# cleanup
cleanupTests
return

18
tests/option.file1 Normal file
View File

@@ -0,0 +1,18 @@
! This file is a sample option (resource) database used to test
! Tk's option-handling capabilities.
! Comment line \
with a backslash-newline sequence embedded in it.
*x1: blue
tktest.x2 : green
*\
x3 \
: pur\
ple
*x 4: brown
# More comments, this time delimited by hash-marks.
# Comment-line with space.
*x6:
*x9: \ \ \\\101\n
# comment line as last line of file.

2
tests/option.file2 Normal file
View File

@@ -0,0 +1,2 @@
*foo1: magenta
foo2 missing colon

18
tests/option.file3 Normal file
View File

@@ -0,0 +1,18 @@
! This file is a sample option (resource) database used to test
! Tk's option-handling capabilities.
! Comment line \
with a backslash-newline sequence embedded in it.
*x1: blue
tktest.x2 : green
*\
x3 \
: pur\
ple
*x 4: brówn
# More comments, this time delimited by hash-marks.
# Comment-line with space.
*x6:
*x9: \ \ \\\101\n
# comment line as last line of file.

425
tests/option.test Normal file
View File

@@ -0,0 +1,425 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}]
deleteWindows
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
# Configurations for tests 1.* - 12.*
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} -body {
option get . x Color1
} -result blue
test option-1.2 {basic option retrieval} -body {
option get . y Color1
} -result red
test option-1.3 {basic option retrieval} -body {
option get . z Color1
} -result red
test option-1.4 {basic option retrieval} -body {
option get . x Color2
} -result blue
test option-1.5 {basic option retrieval} -body {
option get . y Color2
} -result {}
test option-1.6 {basic option retrieval} -body {
option get . z Color2
} -result {}
test option-2.1 {basic option retrieval} -body {
option get .op1 x Color1
} -result green
test option-2.2 {basic option retrieval} -body {
option get .op1 y Color1
} -result red
test option-2.3 {basic option retrieval} -body {
option get .op1 z Color1
} -result red
test option-2.4 {basic option retrieval} -body {
option get .op1 x Color2
} -result green
test option-2.5 {basic option retrieval} -body {
option get .op1 y Color2
} -result {}
test option-2.6 {basic option retrieval} -body {
option get .op1 z Color2
} -result {}
test option-3.1 {basic option retrieval} -body {
option get .op1.op3 x Color1
} -result yellow
test option-3.2 {basic option retrieval} -body {
option get .op1.op3 y Color1
} -result red
test option-3.3 {basic option retrieval} -body {
option get .op1.op3 z Color1
} -result red
test option-3.4 {basic option retrieval} -body {
option get .op1.op3 x Color2
} -result yellow
test option-3.5 {basic option retrieval} -body {
option get .op1.op3 y Color2
} -result {}
test option-3.6 {basic option retrieval} -body {
option get .op1.op3 z Color2
} -result {}
test option-4.1 {basic option retrieval} -body {
option get .op1.op3.op6 x Color1
} -result blue
test option-4.2 {basic option retrieval} -body {
option get .op1.op3.op6 y Color1
} -result red
test option-4.3 {basic option retrieval} -body {
option get .op1.op3.op6 z Color1
} -result red
test option-4.4 {basic option retrieval} -body {
option get .op1.op3.op6 x Color2
} -result black
test option-4.5 {basic option retrieval} -body {
option get .op1.op3.op6 y Color2
} -result black
test option-4.6 {basic option retrieval} -body {
option get .op1.op3.op6 z Color2
} -result black
test option-5.1 {basic option retrieval} -body {
option get .op1.op4 x Color1
} -result blue
test option-5.2 {basic option retrieval} -body {
option get .op1.op4 y Color1
} -result brown
test option-5.3 {basic option retrieval} -body {
option get .op1.op4 z Color1
} -result red
test option-5.4 {basic option retrieval} -body {
option get .op1.op4 x Color2
} -result blue
test option-5.5 {basic option retrieval} -body {
option get .op1.op4 y Color2
} -result brown
test option-5.6 {basic option retrieval} -body {
option get .op1.op4 z Color2
} -result {}
test option-6.1 {basic option retrieval} -body {
option get .op2 x Color1
} -result orange
test option-6.2 {basic option retrieval} -body {
option get .op2 y Color1
} -result orange
test option-6.3 {basic option retrieval} -body {
option get .op2 z Color1
} -result orange
test option-6.4 {basic option retrieval} -body {
option get .op2 x Color2
} -result blue
test option-6.5 {basic option retrieval} -body {
option get .op2 y Color2
} -result {}
test option-6.6 {basic option retrieval} -body {
option get .op2 z Color2
} -result {}
test option-7.1 {basic option retrieval} -body {
option get .op2.op5 x Color1
} -result orange
test option-7.2 {basic option retrieval} -body {
option get .op2.op5 y Color1
} -result orange
test option-7.3 {basic option retrieval} -body {
option get .op2.op5 z Color1
} -result orange
test option-7.4 {basic option retrieval} -body {
option get .op2.op5 x Color2
} -result purple
test option-7.5 {basic option retrieval} -body {
option get .op2.op5 y Color2
} -result purple
test option-7.6 {basic option retrieval} -body {
option get .op2.op5 z Color2
} -result 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} -body {
option get .op2.op5 x Color1
} -result orange
test option-8.2 {stack pushing/popping} -body {
option get .op2.op5 y Color1
} -result orange
test option-8.3 {stack pushing/popping} -body {
option get .op2.op5 z Color1
} -result orange
test option-8.4 {stack pushing/popping} -body {
option get .op2.op5 x Color2
} -result purple
test option-8.5 {stack pushing/popping} -body {
option get .op2.op5 y Color2
} -result purple
test option-8.6 {stack pushing/popping} -body {
option get .op2.op5 z Color2
} -result purple
test option-9.1 {stack pushing/popping} -body {
option get . x Color1
} -result blue
test option-9.2 {stack pushing/popping} -body {
option get . y Color1
} -result red
test option-9.3 {stack pushing/popping} -body {
option get . z Color1
} -result red
test option-9.4 {stack pushing/popping} -body {
option get . x Color2
} -result blue
test option-9.5 {stack pushing/popping} -body {
option get . y Color2
} -result {}
test option-9.6 {stack pushing/popping} -body {
option get . z Color2
} -result {}
test option-10.1 {stack pushing/popping} -body {
option get .op1.op3.op6 x Color1
} -result blue
test option-10.2 {stack pushing/popping} -body {
option get .op1.op3.op6 y Color1
} -result red
test option-10.3 {stack pushing/popping} -body {
option get .op1.op3.op6 z Color1
} -result red
test option-10.4 {stack pushing/popping} -body {
option get .op1.op3.op6 x Color2
} -result black
test option-10.5 {stack pushing/popping} -body {
option get .op1.op3.op6 y Color2
} -result black
test option-10.6 {stack pushing/popping} -body {
option get .op1.op3.op6 z Color2
} -result black
test option-11.1 {stack pushing/popping} -body {
option get .op1.op3 x Color1
} -result yellow
test option-11.2 {stack pushing/popping} -body {
option get .op1.op3 y Color1
} -result red
test option-11.3 {stack pushing/popping} -body {
option get .op1.op3 z Color1
} -result red
test option-11.4 {stack pushing/popping} -body {
option get .op1.op3 x Color2
} -result yellow
test option-11.5 {stack pushing/popping} -body {
option get .op1.op3 y Color2
} -result {}
test option-11.6 {stack pushing/popping} -body {
option get .op1.op3 z Color2
} -result {}
test option-12.1 {stack pushing/popping} -body {
option get .op1 x Color1
} -result green
test option-12.2 {stack pushing/popping} -body {
option get .op1 y Color1
} -result red
test option-12.3 {stack pushing/popping} -body {
option get .op1 z Color1
} -result red
test option-12.4 {stack pushing/popping} -body {
option get .op1 x Color2
} -result green
test option-12.5 {stack pushing/popping} -body {
option get .op1 y Color2
} -result {}
test option-12.6 {stack pushing/popping} -body {
option get .op1 z Color2
} -result {}
# Test the major priority levels (widgetDefault, etc.)
# Configurations for tests 13.*
option clear
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} -body {
option get .op1 a A
} -result 100
test option-13.2 {priority levels} -body {
option get .op1 b A
} -result interactive
test option-13.3 {priority levels} -body {
option get .op1 b B
} -result userDefault
test option-13.4 {priority levels} -body {
option get .op1 c B
} -result startupFile
test option-13.5 {priority levels} -body {
option get .op1 c C
} -result widgetDefault
option add $appName.op1.B file2 widget
test option-13.6 {priority levels} -body {
option get .op1 c B
} -result startupFile
option add $appName.op1.B file2 startupFile
test option-13.7 {priority levels} -body {
option get .op1 c B
} -result file2
# Test various error conditions
test option-14.1 {error conditions} -body {
option
} -returnCodes error -result {wrong # args: should be "option cmd arg ?arg ...?"}
test option-14.2 {error conditions} -body {
option x
} -returnCodes error -result {bad option "x": must be add, clear, get, or readfile}
test option-14.3 {error conditions} -body {
option foo 3
} -returnCodes error -result {bad option "foo": must be add, clear, get, or readfile}
test option-14.4 {error conditions} -body {
option add 3
} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"}
test option-14.5 {error conditions} -body {
option add . a b c
} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"}
test option-14.6 {error conditions} -body {
option add . a -1
} -returnCodes error -result {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
test option-14.7 {error conditions} -body {
option add . a 101
} -returnCodes error -result {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
test option-14.8 {error conditions} -body {
option add . a gorp
} -returnCodes error -result {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
test option-14.9 {error conditions} -body {
option get 3
} -returnCodes error -result {wrong # args: should be "option get window name class"}
test option-14.10 {error conditions} -body {
option get 3 4
} -returnCodes error -result {wrong # args: should be "option get window name class"}
test option-14.11 {error conditions} -body {
option get 3 4 5 6
} -returnCodes error -result {wrong # args: should be "option get window name class"}
test option-14.12 {error conditions} -body {
option get .gorp.gorp a A
} -returnCodes error -result {bad window path name ".gorp.gorp"}
set option1 [file join [testsDirectory] option.file1]
test option-15.1 {database files} -body {
option read non-existent
} -returnCodes error -result {couldn't open "non-existent": no such file or directory}
test option-15.2 {database files} -body {
option read $option1
option get . x1 color
} -result blue
test option-15.3 {database files} -constraints appNameIsTktest -body {
option read $option1
option get . x2 color
} -result green
test option-15.4 {database files} -body {
option read $option1
option get . x3 color
} -result purple
test option-15.5 {database files} -body {
option read $option1
option get . {x 4} color
} -result brown
test option-15.6 {database files} -body {
option read $option1
option get . x6 color
} -result {}
test option-15.7 {database files} -body {
option read $option1
option get . x9 color
} -result " \t\\A\n"
test option-15.8 {database files} -body {
option read $option1 widget foo
} -returnCodes error -result {wrong # args: should be "option readfile fileName ?priority?"}
test option-15.9 {database files} -body {
option add *x3 burgundy
catch {option read $option1 userDefault}
option get . x3 color
} -result burgundy
test option-15.10 {database files} -body {
set option2 [file join [testsDirectory] option.file2]
option read $option2
} -returnCodes error -result {missing colon on line 2}
set option3 [file join [testsDirectory] option.file3]
option read $option3
test option-15.11 {database files} {option get . {x 4} color} br\xf3wn
test option-16.1 {ReadOptionFile} -body {
set option4 [makeFile {} option.file3]
set file [open $option4 w]
fconfigure $file -translation crlf
puts $file "*x7: true\n*x8: false"
close $file
option read $option4 userDefault
list [option get . x7 color] [option get . x8 color]
} -cleanup {
removeFile $option4
} -result {true false}
deleteWindows
# cleanup
cleanupTests
return

1635
tests/pack.test Normal file
View File

File diff suppressed because it is too large Load Diff

250
tests/packgrid.test Normal file
View File

@@ -0,0 +1,250 @@
# This file is a Tcl script to test out interaction between Tk's "pack" and
# "grid" commands.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 2008 Peter Spjuth
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::*
test packgrid-1.1 {pack and grid in same master} -setup {
grid propagate . true
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Basic conflict
grid .g
pack .p
} -returnCodes error -cleanup {
destroy .p
destroy .g
} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
test packgrid-1.2 {pack and grid in same master} -setup {
grid propagate . true
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Basic conflict
pack .p
grid .g
} -returnCodes error -cleanup {
destroy .p
destroy .g
} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
test packgrid-1.3 {pack and grid in same master} -setup {
grid propagate . false
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Ok if one is non-propagating
grid .g
pack .p
} -cleanup {
destroy .p
destroy .g
} -result {}
test packgrid-1.4 {pack and grid in same master} -setup {
grid propagate . false
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Ok if one is non-propagating
pack .p
grid .g
} -cleanup {
destroy .p
destroy .g
} -result {}
test packgrid-1.5 {pack and grid in same master} -setup {
grid propagate . true
pack propagate . false
label .p -text PACK
label .g -text GRID
} -body {
# Ok if one is non-propagating
grid .g
pack .p
} -cleanup {
destroy .p
destroy .g
} -result {}
test packgrid-1.6 {pack and grid in same master} -setup {
grid propagate . true
pack propagate . false
label .p -text PACK
label .g -text GRID
} -body {
# Ok if one is non-propagating
pack .p
grid .g
} -cleanup {
destroy .p
destroy .g
} -result {}
test packgrid-1.7 {pack and grid in same master} -setup {
grid propagate . true
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Basic conflict should stop widget from being handled
grid .g
catch { pack .p }
pack slaves .
} -cleanup {
destroy .p
destroy .g
} -result {}
test packgrid-1.8 {pack and grid in same master} -setup {
grid propagate . true
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Basic conflict should stop widget from being handled
pack .p
catch { grid .g }
grid slaves .
} -cleanup {
destroy .p
destroy .g
} -result {}
test packgrid-2.1 {pack and grid in same master, change propagation} -setup {
grid propagate . false
pack propagate . true
label .p -text PACK
label .g -text GRID
pack .p
grid .g
update
} -body {
grid propagate . true
} -returnCodes error -cleanup {
destroy .p
destroy .g
} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
test packgrid-2.2 {pack and grid in same master, change propagation} -setup {
grid propagate . true
pack propagate . false
label .p -text PACK
label .g -text GRID
pack .p
grid .g
update
} -body {
pack propagate . true
} -returnCodes error -cleanup {
destroy .p
update
destroy .g
} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
test packgrid-2.3 {pack and grid in same master, change propagation} -setup {
grid propagate . false
pack propagate . false
label .p -text PACK
label .g -text GRID
pack .p
grid .g
update
} -body {
grid propagate . true
update
pack propagate . true
} -returnCodes error -cleanup {
destroy .p
destroy .g
} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
test packgrid-2.4 {pack and grid in same master, change propagation} -setup {
grid propagate . false
pack propagate . false
label .p -text PACK
label .g -text GRID
pack .p
grid .g
update
} -body {
pack propagate . true
grid propagate . true
} -returnCodes error -cleanup {
destroy .p
destroy .g
} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
test packgrid-3.1 {stealing slave} -setup {
grid propagate . true
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Ok to steal if the other one is emptied
grid .g
pack .g
} -cleanup {
destroy .p
destroy .g
} -result {}
test packgrid-3.2 {stealing slave} -setup {
grid propagate . true
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Ok to steal if the other one is emptied
pack .g
grid .g
} -cleanup {
destroy .p
destroy .g
} -result {}
test packgrid-3.3 {stealing slave} -setup {
grid propagate . true
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Not ok to steal if the other one is not emptied
grid .g
grid .p
pack .g
} -returnCodes error -cleanup {
destroy .p
destroy .g
} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
test packgrid-3.4 {stealing slave} -setup {
grid propagate . true
pack propagate . true
label .p -text PACK
label .g -text GRID
} -body {
# Not ok to steal if the other one is not emptied
pack .g
pack .p
grid .g
} -returnCodes error -cleanup {
destroy .p
destroy .g
} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
cleanupTests
return

5551
tests/panedwindow.test Normal file
View File

File diff suppressed because it is too large Load Diff

504
tests/place.test Normal file
View File

@@ -0,0 +1,504 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
# XXX - This test file is woefully incomplete. At present, only a
# few of the features are tested.
# Widgets used in tests 1.* - 8.*
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} -setup {
place forget .t.f2
} -body {
place .t.f2 -x 0
place info .t.f2
} -result {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside}
test place-1.2 {Tk_PlaceCmd procedure, "info" option} -setup {
place forget .t.f2
} -body {
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
} -result {-in .t.f -x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside}
test place-1.3 {Tk_PlaceCmd procedure, "info" option} -setup {
place forget .t.f2
destroy .t.a.b
} -body {
# Make sure the result is built as a proper list by using a space in parent
frame ".t.a b"
place .t.f2 -x 1 -y 2 -width {} -height 4 -relx 0.2 -rely 0.2 \
-relwidth 0.3 -relheight {} -anchor w -in ".t.a b" \
-bordermode ignore
place info .t.f2
} -cleanup {
destroy ".t.a.b"
} -result {-in {.t.a b} -x 1 -relx 0.2 -y 2 -rely 0.2 -width {} -relwidth 0.3 -height 4 -relheight {} -anchor w -bordermode ignore}
test place-2.1 {ConfigureSlave procedure, -height option} -body {
place .t.f2 -height abcd
} -returnCodes error -result {bad screen distance "abcd"}
test place-2.2 {ConfigureSlave procedure, -height option} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -height 40
update
winfo height .t.f2
} -result {40}
test place-2.3 {ConfigureSlave procedure, -height option} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -height 120
update
place .t.f2 -height {}
update
winfo height .t.f2
} -result {60}
test place-3.1 {ConfigureSlave procedure, -relheight option} -body {
place .t.f2 -relheight abcd
} -returnCodes error -result {expected floating-point number but got "abcd"}
test place-3.2 {ConfigureSlave procedure, -relheight option} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -relheight .5
update
winfo height .t.f2
} -result {40}
test place-3.3 {ConfigureSlave procedure, -relheight option} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -relheight .8
update
place .t.f2 -relheight {}
update
winfo height .t.f2
} -result {60}
test place-4.1 {ConfigureSlave procedure, bad -in options} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f2
} -returnCodes error -result {can't place .t.f2 relative to itself}
test place-4.2 {ConfigureSlave procedure, bad -in option} -setup {
place forget .t.f2
} -body {
set result [list [winfo manager .t.f2]]
catch {place .t.f2 -in .t.f2}
lappend result [winfo manager .t.f2]
} -result {{} {}}
test place-4.3 {ConfigureSlave procedure, bad -in option} -setup {
place forget .t.f2
} -body {
winfo manager .t.f2
place .t.f2 -in .t.f2
} -returnCodes error -result {can't place .t.f2 relative to itself}
test place-4.4 {ConfigureSlave procedure, bad -in option} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .
} -returnCodes error -result {can't place .t.f2 relative to .}
test place-5.1 {ConfigureSlave procedure, -relwidth option} -body {
place .t.f2 -relwidth abcd
} -returnCodes error -result {expected floating-point number but got "abcd"}
test place-5.2 {ConfigureSlave procedure, -relwidth option} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -relwidth .5
update
winfo width .t.f2
} -result {75}
test place-5.3 {ConfigureSlave procedure, -relwidth option} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -relwidth .8
update
place .t.f2 -relwidth {}
update
winfo width .t.f2
} -result {30}
test place-6.1 {ConfigureSlave procedure, -width option} -body {
place .t.f2 -width abcd
} -returnCodes error -result {bad screen distance "abcd"}
test place-6.2 {ConfigureSlave procedure, -width option} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -width 100
update
winfo width .t.f2
} -result {100}
test place-6.3 {ConfigureSlave procedure, -width option} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -width 120
update
place .t.f2 -width {}
update
winfo width .t.f2
} -result {30}
test place-7.1 {ReconfigurePlacement procedure, computing position} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -x -2 -relx .5 -y 3 -rely .4
update
winfo geometry .t.f2
} -result {30x60+123+75}
test place-7.2 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -x -1.4 -y -2.3
update
winfo geometry .t.f2
} -result {30x60+49+38}
test place-7.3 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -x 1.4 -y 2.3
update
winfo geometry .t.f2
} -result {30x60+51+42}
test place-7.4 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -x -1.6 -y -2.7
update
winfo geometry .t.f2
} -result {30x60+48+37}
test place-7.5 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -x 1.6 -y 2.7
update
winfo geometry .t.f2
} -result {30x60+52+43}
test place-7.6 {ReconfigurePlacement procedure, position rounding} -setup {
destroy .t.f3
} -body {
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
} -cleanup {
destroy .t.f3
} -result {31x20+30+41}
test place-7.7 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -width 120 -height 89
update
list [winfo width .t.f2] [winfo height .t.f2]
} -result {120 89}
test place-7.8 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -relwidth .4 -relheight .5
update
list [winfo width .t.f2] [winfo height .t.f2]
} -result {60 40}
test place-7.9 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
} -body {
place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
update
list [winfo width .t.f2] [winfo height .t.f2]
} -result {70 36}
test place-7.10 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
} -body {
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]
} -result {30 60}
test place-8.1 {MasterStructureProc, mapping and unmapping slaves} -setup {
place forget .t.f2
place forget .t.f
} -body {
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]
} -result {1 0 40 30 0 1}
test place-8.2 {MasterStructureProc, mapping and unmapping slaves} -setup {
place forget .t.f2
place forget .t.f
} -body {
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]
} -result {1 0 42 32 0 1}
destroy .t
test place-9.1 {PlaceObjCmd} -body {
place
} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
test place-9.2 {PlaceObjCmd} -body {
place foo
} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
test place-9.3 {PlaceObjCmd} -setup {
destroy .foo
} -body {
place .foo bar
} -returnCodes error -result {bad window path name ".foo"}
test place-9.4 {PlaceObjCmd} -setup {
destroy .foo
} -body {
place bar .foo
} -cleanup {
destroy .foo
} -returnCodes error -result {bad window path name ".foo"}
test place-9.5 {PlaceObjCmd} -setup {
destroy .foo
} -body {
frame .foo
place badopt .foo
} -cleanup {
destroy .foo
} -returnCodes error -result {bad option "badopt": must be configure, forget, info, or slaves}
test place-9.6 {PlaceObjCmd, configure errors} -setup {
destroy .foo
} -body {
frame .foo
place configure .foo
} -cleanup {
destroy .foo
} -returnCodes ok -result {}
test place-9.7 {PlaceObjCmd, configure errors} -setup {
destroy .foo
} -body {
frame .foo
place configure .foo bar
} -cleanup {
destroy .foo
} -returnCodes ok -result {}
test place-9.8 {PlaceObjCmd, configure} -setup {
destroy .foo
} -body {
frame .foo
place .foo -x 0 -y 0
place configure .foo
} -cleanup {
destroy .foo
} -result [list {-anchor {} {} nw nw} {-bordermode {} {} inside inside} {-height {} {} {} {}} {-in {} {} {} .} {-relheight {} {} {} {}} {-relwidth {} {} {} {}} {-relx {} {} 0 0.0} {-rely {} {} 0 0.0} {-width {} {} {} {}} {-x {} {} 0 0} {-y {} {} 0 0}]
test place-9.9 {PlaceObjCmd, configure} -setup {
destroy .foo
} -body {
frame .foo
place .foo -x 0 -y 0
place configure .foo -x
} -cleanup {
destroy .foo
} -result {-x {} {} 0 0}
test place-9.10 {PlaceObjCmd, forget errors} -setup {
destroy .foo
} -body {
frame .foo
place forget .foo bar
} -cleanup {
destroy .foo
} -returnCodes error -result {wrong # args: should be "place forget pathName"}
test place-9.11 {PlaceObjCmd, info errors} -setup {
destroy .foo
} -body {
frame .foo
place info .foo bar
} -cleanup {
destroy .foo
} -returnCodes error -result {wrong # args: should be "place info pathName"}
test place-9.12 {PlaceObjCmd, slaves errors} -setup {
destroy .foo
} -body {
frame .foo
place slaves .foo bar
} -cleanup {
destroy .foo
} -returnCodes error -result {wrong # args: should be "place slaves pathName"}
test place-10.1 {ConfigureSlave} -setup {
destroy .foo
} -body {
frame .foo
place .foo -badopt
} -cleanup {
destroy .foo
} -returnCodes error -result {unknown option "-badopt"}
test place-10.2 {ConfigureSlave} -setup {
destroy .foo
} -body {
frame .foo
place .foo -anchor
} -cleanup {
destroy .foo
} -returnCodes error -result {value for "-anchor" missing}
test place-10.3 {ConfigureSlave} -setup {
destroy .foo
} -body {
frame .foo
place .foo -bordermode j
} -cleanup {
destroy .foo
} -returnCodes error -result {bad bordermode "j": must be inside, outside, or ignore}
test place-10.4 {ConfigureSlave} -setup {
destroy .foo
} -body {
frame .foo
place configure .foo -x 0 -y
} -cleanup {
destroy .foo
} -returnCodes error -result {value for "-y" missing}
test place-11.1 {PlaceObjCmd, slaves command} -setup {
destroy .foo
} -body {
frame .foo
place slaves .foo
} -cleanup {
destroy .foo
} -result {}
test place-11.2 {PlaceObjCmd, slaves command} -setup {
destroy .foo .bar
} -body {
frame .foo
frame .bar
place .bar -in .foo
place slaves .foo
} -cleanup {
destroy .foo .bar
} -result [list .bar]
test place-12.1 {PlaceObjCmd, forget command} -setup {
destroy .foo
} -body {
frame .foo
place .foo -width 50 -height 50
update
set res [winfo ismapped .foo]
place forget .foo
update
lappend res [winfo ismapped .foo]
} -cleanup {
destroy .foo
} -result {1 0}
test place-13.1 {test respect for internalborder} -setup {
destroy .pack
} -body {
toplevel .pack
wm geometry .pack 200x200
frame .pack.l -width 15 -height 10
labelframe .pack.lf -labelwidget .pack.l
pack .pack.lf -fill both -expand 1
frame .pack.lf.f
place .pack.lf.f -x 0 -y 0 -relwidth 1.0 -relheight 1.0
update
set res [list [winfo geometry .pack.lf.f]]
.pack.lf configure -labelanchor e -padx 3 -pady 5
update
lappend res [winfo geometry .pack.lf.f]
} -cleanup {
destroy .pack
} -result {196x188+2+10 177x186+5+7}
test place-14.1 {memory leak testing} -constraints memory -setup {
destroy .f
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
}
# Repeat each body checking that memory does not increase
proc stress {args} {
set res {}
foreach body $args {
set end 0
for {set i 0} {$i < 5} {incr i} {
uplevel 1 $body
set tmp $end
set end [getbytes]
}
lappend res [expr {$end - $tmp}]
}
return $res
}
} -body {
# Test all manners of forgetting a slave
frame .f
frame .f.f
stress {
place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
place forget .f.f
} {
place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
pack .f.f
} {
place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
destroy .f
frame .f
frame .f.f
}
} -cleanup {
destroy .f
rename getbytes {}
rename stress {}
} -result {0 0 0}
# cleanup
cleanupTests
return

BIN
tests/pwrdLogo150.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 2.4 KiB

320
tests/raise.test Normal file
View File

@@ -0,0 +1,320 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
# 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 {} {
deleteWindows
foreach i {.raise1 .raise2 .raise3} {
toplevel $i
wm geom $i 150x100+0+0
update
}
}
toplevel .raise
wm geom .raise 250x200+0+0
test raise-1.1 {preserve creation order} -body {
raise_setup
tkwait visibility .raise.e
raise_getOrder
} -result {d d d b c e e e}
test raise-1.2 {preserve creation order} -constraints testmakeexist -body {
raise_setup
testmakeexist .raise.a
update
raise_getOrder
} -result {d d d b c e e e}
test raise-1.3 {preserve creation order} -constraints testmakeexist -body {
raise_setup
testmakeexist .raise.c
update
raise_getOrder
} -result {d d d b c e e e}
test raise-1.4 {preserve creation order} -constraints testmakeexist -body {
raise_setup
testmakeexist .raise.e
update
raise_getOrder
} -result {d d d b c e e e}
test raise-1.5 {preserve creation order} -constraints testmakeexist -body {
raise_setup
testmakeexist .raise.d .raise.c .raise.b
update
raise_getOrder
} -result {d d d b c e e e}
test raise-2.1 {raise internal windows before creation} -body {
raise_setup
raise .raise.a
update
raise_getOrder
} -result {a d d a c a e e}
test raise-2.2 {raise internal windows before creation} -body {
raise_setup
raise .raise.c
update
raise_getOrder
} -result {d d c b c e e c}
test raise-2.3 {raise internal windows before creation} -body {
raise_setup
raise .raise.e
update
raise_getOrder
} -result {d d d b c e e e}
test raise-2.4 {raise internal windows before creation} -body {
raise_setup
raise .raise.e .raise.a
update
raise_getOrder
} -result {d d d b c e b c}
test raise-2.5 {raise internal windows before creation} -body {
raise_setup
raise .raise.a .raise.d
update
raise_getOrder
} -result {a d d a c e e e}
test raise-3.1 {raise internal windows after creation} -body {
raise_setup
update
raise .raise.a .raise.d
raise_getOrder
} -result {a d d a c e e e}
test raise-3.2 {raise internal windows after creation} -constraints {
testmakeexist
} -body {
raise_setup
testmakeexist .raise.a .raise.b
raise .raise.a .raise.b
update
raise_getOrder
} -result {d d d a c e e e}
test raise-3.3 {raise internal windows after creation} -constraints {
testmakeexist
} -body {
raise_setup
testmakeexist .raise.a .raise.d
raise .raise.a .raise.b
update
raise_getOrder
} -result {d d d a c e e e}
test raise-3.4 {raise internal windows after creation} -constraints {
testmakeexist
} -body {
raise_setup
testmakeexist .raise.a .raise.c .raise.d
raise .raise.a .raise.b
update
raise_getOrder
} -result {d d d a c e e e}
test raise-4.1 {raise relative to nephews} -body {
raise_setup
update
frame .raise.d.child
raise .raise.a .raise.d.child
raise_getOrder
} -result {a d d a c e e e}
test raise-4.2 {raise relative to nephews} -setup {
destroy .raise2
} -body {
raise_setup
update
frame .raise2
raise .raise.a .raise2
} -cleanup {
destroy .raise2
} -returnCodes error -result {can't raise ".raise.a" above ".raise2"}
test raise-5.1 {lower internal windows} -body {
raise_setup
update
lower .raise.d
raise_getOrder
} -result {a b c b c e e e}
test raise-5.2 {lower internal windows} -body {
raise_setup
update
lower .raise.d .raise.b
raise_getOrder
} -result {d b c b c e e e}
test raise-5.3 {lower internal windows} -body {
raise_setup
update
lower .raise.a .raise.e
raise_getOrder
} -result {a d d a c e e e}
test raise-5.4 {lower internal windows} -setup {
destroy .raise2
} -body {
raise_setup
update
frame .raise2
lower .raise.a .raise2
} -cleanup {
destroy .raise2
} -returnCodes error -result {can't lower ".raise.a" below ".raise2"}
test raise-6.1 {raise/lower toplevel windows} -constraints {
nonPortable
} -body {
raise_makeToplevels
update
raise .raise1
winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
} -result {.raise1}
test raise-6.2 {raise/lower toplevel windows} -constraints {
nonPortable
} -body {
raise_makeToplevels
update
raise .raise2
winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
} -result {.raise2}
test raise-6.3 {raise/lower toplevel windows} -constraints {
nonPortable
} -body {
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]]
} -result {.raise2 .raise1}
test raise-6.4 {raise/lower toplevel windows} -constraints {
nonPortable
} -body {
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]]
} -result {.raise1 .raise3}
test raise-6.5 {raise/lower toplevel windows} -constraints {
nonPortable
} -body {
raise_makeToplevels
raise .raise1
set time [lindex [time {raise .raise1}] 0]
expr {$time < 2000000}
} -result 1
test raise-6.6 {raise/lower toplevel windows} -constraints {
nonPortable
} -body {
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]]
} -result {.raise1 .raise3}
test raise-7.1 {errors in raise/lower commands} -body {
raise
} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"}
test raise-7.2 {errors in raise/lower commands} -body {
raise a b c
} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"}
test raise-7.3 {errors in raise/lower commands} -body {
raise badName
} -returnCodes error -result {bad window path name "badName"}
test raise-7.4 {errors in raise/lower commands} -body {
raise . badName2
} -returnCodes error -result {bad window path name "badName2"}
test raise-7.5 {errors in raise/lower commands} -body {
lower
} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"}
test raise-7.6 {errors in raise/lower commands} -body {
lower a b c
} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"}
test raise-7.7 {errors in raise/lower commands} -body {
lower badName3
} -returnCodes error -result {bad window path name "badName3"}
test raise-7.8 {errors in raise/lower commands} -body {
lower . badName4
} -returnCodes error -result {bad window path name "badName4"}
deleteWindows
# cleanup
cleanupTests
return

248
tests/safe.test Normal file
View File

@@ -0,0 +1,248 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
## NOTE: Any time tests fail here with an error like:
# Can't find a usable tk.tcl in the following directories:
# {$p(:26:)}
#
# $p(:26:)/tk.tcl: script error
# script error
# invoked from within
# "source {$p(:26:)/tk.tcl}"
# ("uplevel" body line 1)
# invoked from within
# "uplevel #0 [list source $file]"
#
#
# This probably means that tk wasn't installed properly.
## it indicates that something went wrong sourcing tk.tcl.
## Ensure that any changes that occured to tk.tcl will work or are properly
## prevented in a safe interpreter. -- hobbs
# The set of hidden commands is platform dependent:
set hidden_cmds {bell cd clipboard encoding exec exit fconfigure glob grab load menu open pwd selection socket source toplevel unload wm}
lappend hidden_cmds {*}[apply {{} {
foreach cmd {
atime attributes copy delete dirname executable exists extension
isdirectory isfile link lstat mkdir mtime nativename normalize owned
readable readlink rename rootname size stat tail tempfile type
volumes writable
} {lappend result tcl:file:$cmd}; return $result
}}]
if {[tk windowingsystem] ne "x11"} {
lappend hidden_cmds tk_chooseColor tk_chooseDirectory tk_getOpenFile \
tk_getSaveFile tk_messageBox
}
if {[llength [info commands send]]} {
lappend hidden_cmds send
}
set saveAutoPath $::auto_path
set auto_path [list [info library] $::tk_library]
set hidden_cmds [lsort $hidden_cmds]
test safe-1.1 {Safe Tk loading into an interpreter} -setup {
catch {safe::interpDelete a}
} -body {
safe::loadTk [safe::interpCreate a]
safe::interpDelete a
set x {}
return $x
} -result {}
test safe-1.2 {Safe Tk loading into an interpreter} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::loadTk a
lsort [interp hidden a]
} -cleanup {
safe::interpDelete a
} -result $hidden_cmds
test safe-1.3 {Safe Tk loading into an interpreter} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::loadTk a
lsort [interp aliases a]
} -cleanup {
safe::interpDelete a
} -match glob -result {*encoding*exit*glob*load*source*}
test safe-2.1 {Unsafe commands not available} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::loadTk a
set status broken
if {[catch {interp eval a {toplevel .t}} msg]} {
set status ok
}
return $status
} -cleanup {
safe::interpDelete a
} -result ok
test safe-2.2 {Unsafe commands not available} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::loadTk a
set status broken
if {[catch {interp eval a {menu .m}} msg]} {
set status ok
}
return $status
} -cleanup {
safe::interpDelete a
} -result ok
test safe-2.3 {Unsafe subcommands not available} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::loadTk a
set status broken
if {[catch {interp eval a {tk appname}} msg]} {
set status ok
}
list $status $msg
} -cleanup {
safe::interpDelete a
} -result {ok {appname not accessible in a safe interpreter}}
test safe-2.4 {Unsafe subcommands not available} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::loadTk a
set status broken
if {[catch {interp eval a {tk scaling}} msg]} {
set status ok
}
list $status $msg
} -cleanup {
safe::interpDelete a
} -result {ok {scaling not accessible in a safe interpreter}}
test safe-3.1 {Unsafe commands are available hidden} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::loadTk a
set status ok
if {[catch {interp invokehidden a toplevel .t} msg]} {
set status broken
}
return $status
} -cleanup {
safe::interpDelete a
} -result ok
test safe-3.2 {Unsafe commands are available hidden} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::loadTk a
set status ok
if {[catch {interp invokehidden a menu .m} msg]} {
set status broken
}
return $status
} -cleanup {
safe::interpDelete a
} -result ok
test safe-4.1 {testing loadTk} -body {
# 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 imply 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
} -result {}
test safe-4.2 {testing loadTk -use} -setup {
destroy .safeTkFrame
} -body {
set w .safeTkFrame
frame $w -container 1;
pack $w
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
} -result {}
test safe-5.1 {loading Tk in safe interps without master's clearance} -body {
set i [safe::interpCreate]
interp eval $i {load {} Tk}
} -cleanup {
safe::interpDelete $i
} -returnCodes error -result {not allowed}
test safe-5.2 {multi-level Tk loading with clearance} -setup {
set safeParent [safe::interpCreate]
} -body {
# No error shall occur in that test and no window shall remain at the end.
set i [safe::interpCreate [list $safeParent x]]
safe::loadTk $i
interp eval $i {
button .b -text Ok -command {destroy .}
pack .b
# tkwait window . ; # for interactive testing/debugging
}
} -cleanup {
catch {safe::interpDelete $i}
safe::interpDelete $safeParent
} -result {}
test safe-6.1 {loadTk -use windowPath} -setup {
destroy .safeTkFrame
} -body {
set w .safeTkFrame
frame $w -container 1;
pack $w
set i [safe::loadTk [safe::interpCreate] -use $w]
interp eval $i {button .b -text "hello world!"; pack .b}
safe::interpDelete $i
destroy $w
} -result {}
test safe-6.2 {loadTk -use windowPath, conflicting -display} -setup {
destroy .safeTkFrame
} -body {
set w .safeTkFrame
frame $w -container 1;
pack $w
set i [safe::interpCreate]
catch {safe::loadTk $i -use $w -display :23.56} msg
string range $msg 0 36
} -cleanup {
safe::interpDelete $i
destroy $w
} -result {conflicting -display :23.56 and -use }
test safe-7.1 {canvas printing} -body {
set i [safe::loadTk [safe::interpCreate]]
interp eval $i {canvas .c; .c postscript}
} -cleanup {
safe::interpDelete $i
} -returnCodes ok -match glob -result *
# cleanup
set ::auto_path $saveAutoPath
unset hidden_cmds
cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:

1511
tests/scale.test Normal file
View File

File diff suppressed because it is too large Load Diff

707
tests/scrollbar.test Normal file
View File

@@ -0,0 +1,707 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
proc scroll args {
global scrollInfo
set scrollInfo $args
}
proc getTroughSize {w} {
if {[testConstraint testmetrics]} {
if [string match v* [$w cget -orient]] {
return [expr [winfo height $w] - 2*[testmetrics cyvscroll $w]]
} else {
return [expr [winfo width $w] - 2*[testmetrics cxhscroll $w]]
}
} 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 "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 "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" {} {}}
{-troughcolor #432 #432 lousy {unknown color name "lousy"}}
{-width 32 32 badValue {bad screen distance "badValue"}}
} {
lassign $test name value okResult badValue badResult
# Assume $name is plain; true of all our in-use options!
test scrollbar-1.$i {configuration options} \
".s configure $name [list $value]; .s cget $name" $okResult
incr i
if {$badValue ne ""} {
test scrollbar-1.$i {configuration options} \
-body [list .s configure $name $badValue] \
-returnCodes error -result $badResult
incr i
}
.s configure $name [lindex [.s configure $name] 3]
}
destroy .s
test scrollbar-2.1 {Tk_ScrollbarCmd procedure} -returnCodes error -body {
scrollbar
} -result {wrong # args: should be "scrollbar pathName ?-option value ...?"}
test scrollbar-2.2 {Tk_ScrollbarCmd procedure} -body {
scrollbar gorp
} -returnCodes error -result {bad window path name "gorp"}
test scrollbar-2.3 {Tk_ScrollbarCmd procedure} -setup {
scrollbar .s
} -body {
list [winfo class .s] [info command .s]
} -cleanup {
destroy .s
} -result {Scrollbar .s}
test scrollbar-2.4 {Tk_ScrollbarCmd procedure} {
list [catch {scrollbar .s -gorp blah} msg] $msg [winfo exists .s] \
[info command .s]
} {1 {unknown option "-gorp"} 0 {}}
test scrollbar-2.5 {Tk_ScrollbarCmd procedure} -setup {
catch {destroy .s}
} -body {
scrollbar .s
} -cleanup {
destroy .s
} -result .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 ...?"}}
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} {
expr {[.s2 cget -bd] == [lindex [.s2 configure -bd] 3]}
} 1
test scrollbar-3.12 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
# empty test; duplicated scrollbar-3.11
} {}
test scrollbar-3.12.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
# empty test; duplicated scrollbar-3.11
} {}
test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} {
expr {[.s2 cget -highlightthickness] == [lindex [.s2 configure -highlightthickness] 3]}
} 1
test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
# empty test; duplicated scrollbar-3.13
} {}
test scrollbar-3.14.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
# empty test; duplicated scrollbar-3.13
} {}
destroy .s2
test scrollbar-3.15 {ScrollbarWidgetCmd procedure, "configure" option} {
llength [.s configure]
} {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} {
format {%.6g} [.s delta 20 0]
} {0}
test scrollbar-3.26 {ScrollbarWidgetCmd procedure, "delta" option} {
format {%.6g} [.s delta 0 20]
} [format %.6g [expr 20.0/([getTroughSize .s]-1)]]
test scrollbar-3.27 {ScrollbarWidgetCmd procedure, "delta" option} {
format {%.6g} [.s delta 0 -20]
} [format %.6g [expr -20.0/([getTroughSize .s]-1)]]
test scrollbar-3.28 {ScrollbarWidgetCmd procedure, "delta" option} {
toplevel .t -width 250 -height 100
wm geom .t +0+0
scrollbar .t.s -orient horizontal -borderwidth 2
place .t.s -width 201
update
set result [list [format {%.6g} [.t.s delta 0 20]] \
[format {%.6g} [.t.s delta [expr [getTroughSize .t.s] - 1] 0]]]
destroy .t
set result
} {0 1}
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} {
format {%.6g} [.s fraction 0 0]
} {0}
test scrollbar-3.34 {ScrollbarWidgetCmd procedure, "fraction" option} {
format {%.6g} [.s fraction 0 1000]
} {1}
test scrollbar-3.35 {ScrollbarWidgetCmd procedure, "fraction" option} {
format {%.6g} [.s fraction 4 21]
} [format %.6g [expr (21.0 - ([winfo height .s] - [getTroughSize .s])/2.0) \
/([getTroughSize .s] - 1)]]
test scrollbar-3.36 {ScrollbarWidgetCmd procedure, "fraction" option} unix {
format {%.6g} [.s fraction 4 179]
} {1}
test scrollbar-3.37 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics} {
format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s]]]
} {1}
test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} unix {
format {%.6g} [.s fraction 4 178]
} {0.993711}
test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics win} {
expr \
[format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s] - 2]]] \
== [format %g [expr (200.0 - [testmetrics cyvscroll .s]*2 - 2) \
/ ($height - 1 - [testmetrics cyvscroll .s]*2)]]
} 1
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} {
format {%.6g} [.t.s fraction 100 0]
} {0.5}
if {[testConstraint testmetrics]} {
place configure .t.s -width [expr 2*[testmetrics cxhscroll .t.s]+1]
} else {
place configure .t.s -width [expr [winfo reqwidth .t.s] - 4]
}
update
test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} {
format {%.6g} [.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.56 {ScrollbarWidgetCmd procedure, "identify" option} unix {
.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 {ambiguous 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} unix {
.s identify 8 3
} {}
test scrollbar-6.3 {ScrollbarPosition procedure} unix {
.s identify 8 196
} {}
test scrollbar-6.4 {ScrollbarPosition procedure} unix {
.s identify 3 100
} {}
test scrollbar-6.6 {ScrollbarPosition procedure} unix {
.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} unix {
.s identify 8 4
} {arrow1}
test scrollbar-6.12 {ScrollbarPosition procedure} unix {
.s identify 8 19
} {arrow1}
test scrollbar-6.14 {ScrollbarPosition procedure} win {
.s identify [expr [winfo width .s] / 2] 0
} {arrow1}
test scrollbar-6.15 {ScrollbarPosition procedure} {testmetrics win} {
.s identify [expr [winfo width .s] / 2] [expr [testmetrics cyvscroll .s] - 1]
} {arrow1}
test scrollbar-6.16 {ScrollbarPosition procedure} unix {
.s identify 8 20
} {trough1}
test scrollbar-6.17 {ScrollbarPosition procedure} {unix nonPortable} {
# Don't know why this is non-portable, but it doesn't work on
# some platforms.
.s identify 8 51
} {trough1}
test scrollbar-6.18 {ScrollbarPosition procedure} {testmetrics win} {
.s identify [expr [winfo width .s] / 2] [testmetrics cyvscroll .s]
} {trough1}
test scrollbar-6.19 {ScrollbarPosition procedure} {testmetrics win} {
.s identify [expr [winfo width .s] / 2] [expr int(.2 / [.s delta 0 1]) \
+ [testmetrics cyvscroll .s] - 1]
} {trough1}
test scrollbar-6.20 {ScrollbarPosition procedure} unix {
.s identify 8 52
} {slider}
test scrollbar-6.21 {ScrollbarPosition procedure} {unix nonPortable} {
# Don't know why this is non-portable, but it doesn't work on
# some platforms.
.s identify 8 83
} {slider}
test scrollbar-6.22 {ScrollbarPosition procedure} {testmetrics win} {
.s identify [expr [winfo width .s] / 2] \
[expr int(.2 / [.s delta 0 1] + 0.5) + [testmetrics cyvscroll .s]]
} {slider}
test scrollbar-6.23 {ScrollbarPosition procedure} {testmetrics win} {
.s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \
+ [testmetrics cyvscroll .s] - 1]
} {slider}
test scrollbar-6.24 {ScrollbarPosition procedure} unix {
.s identify 8 84
} {trough2}
test scrollbar-6.25 {ScrollbarPosition procedure} unix {
.s identify 8 179
} {trough2}
test scrollbar-6.27 {ScrollbarPosition procedure} {testmetrics win knownBug} {
# This asks for 8,21, which is actually the slider, but there is a
# bug in that GetSystemMetrics(SM_CYVTHUMB) actually returns a value
# that is larger than the thumb displayed, skewing the ability to
# calculate the trough2 area correctly (Win2k). -- hobbs
.s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \
+ [testmetrics cyvscroll .s]]
} {trough2}
test scrollbar-6.28 {ScrollbarPosition procedure} {testmetrics win} {
.s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \
- [testmetrics cyvscroll .s] - 1]
} {trough2}
test scrollbar-6.29 {ScrollbarPosition procedure} unix {
.s identify 8 180
} {arrow2}
test scrollbar-6.30 {ScrollbarPosition procedure} unix {
.s identify 8 195
} {arrow2}
test scrollbar-6.32 {ScrollbarPosition procedure} {testmetrics win} {
.s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \
- [testmetrics cyvscroll .s]]
} {arrow2}
test scrollbar-6.33 {ScrollbarPosition procedure} win {
.s identify [expr [winfo width .s] / 2] [expr [winfo height .s] - 1]
} {arrow2}
test scrollbar-6.34 {ScrollbarPosition procedure} unix {
.s identify 4 100
} {trough2}
test scrollbar-6.35 {ScrollbarPosition procedure} unix {
.s identify 18 100
} {trough2}
test scrollbar-6.37 {ScrollbarPosition procedure} win {
.s identify 0 100
} {trough2}
test scrollbar-6.38 {ScrollbarPosition procedure} win {
.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} unix {
.t.s identify 4 8
} {arrow1}
test scrollbar-6.40 {ScrollbarPosition procedure} win {
.t.s identify 0 [expr [winfo height .t.s] / 2]
} {arrow1}
test scrollbar-6.41 {ScrollbarPosition procedure} unix {
.t.s identify 82 8
} {slider}
test scrollbar-6.43 {ScrollbarPosition procedure} {testmetrics win} {
.t.s identify [expr int(.4 / [.t.s delta 1 0]) + [testmetrics cxhscroll .t.s] \
- 1] [expr [winfo height .t.s] / 2]
} {slider}
test scrollbar-6.44 {ScrollbarPosition procedure} unix {
.t.s identify 100 18
} {trough2}
test scrollbar-6.46 {ScrollbarPosition procedure} win {
.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} {}
destroy .t.f
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
event generate .t <ButtonRelease> -button 1
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} {}
destroy .t.f
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
event generate .t.f <ButtonRelease> -button 1
update
lappend result [winfo exists .t.f.s] [winfo exists .t.f]
rename bgerror {}
set result
} {1 0 1}
set l [interp hidden]
deleteWindows
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]
test scrollbar-10.1 {<MouseWheel> event on scrollbar} -constraints {win|unix} -setup {
destroy .t .s
} -body {
pack [text .t -yscrollcommand {.s set}] -side left
for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"}
pack [scrollbar .s -command {.t yview}] -fill y -expand 1 -side left
update
focus -force .s
event generate .s <MouseWheel> -delta -120
after 200 {set eventprocessed 1} ; vwait eventprocessed
.t index @0,0
} -cleanup {
destroy .t .s
} -result {5.0}
test scrollbar-10.2 {<MouseWheel> event on scrollbar} -constraints {win|unix} -setup {
destroy .t .s
} -body {
pack [text .t -xscrollcommand {.s set} -wrap none] -side top
for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "}
pack [scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top
update
focus -force .s
event generate .s <Shift-MouseWheel> -delta -120
after 200 {set eventprocessed 1} ; vwait eventprocessed
.t index @0,0
} -cleanup {
destroy .t .s
} -result {1.4}
test scrollbar-11.1 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destruction} -body {
proc destroy_scrollbar {} {
if {[winfo exists .top.s]} {
destroy .top.s
}
}
toplevel .top
scrollbar .top.s
bind .top.s <2> {destroy_scrollbar}
pack .top.s
focus -force .top.s
update
event generate .top.s <2>
update ; # shall not trigger error invalid command name ".top.s"
} -cleanup {
destroy .top.s .top
} -result {}
test scrollbar-11.2 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destruction} -body {
proc destroy_scrollbar {{y 0}} {
if {[winfo exists .top.s]} {
destroy .top.s
}
}
toplevel .top
wm minsize .top 50 400
update
scrollbar .top.s
bind .top.s <2> {after idle destroy_scrollbar}
pack .top.s -expand true -fill y
focus -force .top.s
update
event generate .top.s <2> -x 2 -y [expr {[winfo height .top.s] / 2}]
update ; # shall not trigger error invalid command name ".top.s"
} -cleanup {
destroy .top.s .top
} -result {}
catch {destroy .s}
catch {destroy .t}
# cleanup
cleanupTests
return

1160
tests/select.test Normal file
View File

File diff suppressed because it is too large Load Diff

624
tests/send.test Normal file
View File

@@ -0,0 +1,624 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by ActiveState Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
testConstraint xhost [llength [auto_execok xhost]]
# 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]
set commId ""
catch {
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 .}
test send-1.1 {RegOpen procedure, bogus property} {secureserver testsend} {
testsend bogus
set result [winfo interps]
tk appname tktest
list $result [winfo interps]
} {{} tktest}
test send-1.2 {RegOpen procedure, bogus property} {secureserver testsend} {
testsend prop root InterpRegistry {}
set result [winfo interps]
tk appname tktest
list $result [winfo interps]
} {{} tktest}
test send-1.3 {RegOpen procedure, bogus property} {secureserver testsend} {
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} {secureserver testsend} {
testsend prop root InterpRegistry {}
list [catch {send foo bar} msg] $msg
} {1 {no application named "foo"}}
test send-2.2 {RegFindName procedure} {secureserver testsend} {
testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n"
tk appname foo
} {foo #2}
test send-2.3 {RegFindName procedure} {secureserver testsend} {
testsend prop root InterpRegistry "gyz foo\n"
tk appname foo
} {foo}
test send-2.4 {RegFindName procedure} {secureserver testsend} {
testsend prop root InterpRegistry "${id}z foo\n"
tk appname foo
} {foo}
test send-3.1 {RegDeleteName procedure} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
testsend prop root InterpRegistry ""
tk appname bar
testsend prop root InterpRegistry
} "$commId bar\n"
test send-4.2 {RegAddName procedure} {secureserver testsend} {
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} {secureserver testsend} {
testsend prop root InterpRegistry "123 abc\n"
winfo interps
} {}
test send-5.2 {ValidateName procedure} {secureserver testsend} {
testsend prop root InterpRegistry "$id Hi there"
winfo interps
} {{Hi there}}
test send-5.3 {ValidateName procedure} {secureserver testsend} {
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} {secureserver testsend} {
tk appname test
testsend prop root InterpRegistry "$commId Bogus\n$commId test\n"
winfo interps
} {test}
if {[testConstraint nonPortable] && [testConstraint xhost]} {
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 secureserver} {
set a 44
list [dobg [list send [tk appname] set a 55]] $a
} {55 55}
test send-6.2 {ServerSecure procedure} {nonPortable secureserver xhost} {
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 secureserver xhost} {
set a abc
exec xhost - [exec hostname]
list [dobg [list send [tk appname] set a new]] $a
} {new new}
cleanupbg
test send-7.1 {Tk_SetAppName procedure} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver} {
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}
test send-8.2 {Tk_SendCmd procedure, options} {secureserver altDisplay} {
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} {secureserver} {
list [catch {send -- -async foo bar baz} msg] $msg
} {1 {no application named "-async"}}
test send-8.4 {Tk_SendCmd procedure, options} {secureserver} {
list [catch {send -gorp foo bar baz} msg] $msg
} {1 {no application named "-gorp"}}
test send-8.5 {Tk_SendCmd procedure, options} {secureserver} {
list [catch {send -async foo} msg] $msg
} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}}
test send-8.6 {Tk_SendCmd procedure, options} {secureserver} {
list [catch {send foo} msg] $msg
} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}}
test send-8.7 {Tk_SendCmd procedure, local execution} {secureserver} {
set a initial
send [tk appname] {set a new}
set a
} {new}
test send-8.8 {Tk_SendCmd procedure, local execution} {secureserver} {
set a initial
send [tk appname] set a new
set a
} {new}
test send-8.9 {Tk_SendCmd procedure, local execution} {secureserver} {
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} {secureserver} {
list [catch {send bogus_name bogus_command} msg] $msg
} {1 {no application named "bogus_name"}}
catch {
newApp "" t_s_1 Test
t_s_1 eval wm withdraw .
}
test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
newApp "" t_s_2 Test
list [catch {send t_s_2 {destroy .; concat result}} msg] $msg
} {0 result}
catch {interp delete t_s_2}
test send-8.15 {Tk_SendCmd procedure, local interp, error info} {secureserver testsend} {
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
"if 1 {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} {secureserver testsend} {
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"}}
catch {interp delete t_s_1}
test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver 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} {secureserver} {
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} {secureserver} {
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]
test send-9.1 {Tk_GetInterpNames procedure} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
testsend prop root InterpRegistry {}
list [winfo interps] [testsend prop root InterpRegistry]
} {{} {}}
catch {testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"}
test send-10.1 {SendEventProc procedure, bogus comm property} {secureserver testsend} {
testsend prop comm Comm {abc def}
testsend prop comm Comm {}
update
} {}
test send-10.2 {SendEventProc procedure, simultaneous messages} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
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} {secureserver testsend} {
setupbg
dobg {tk appname t_s_3}
set x [list [catch {send t_s_3 exit} msg] $msg]
cleanupbg
set x
} {1 {target application died}}
test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {secureserver testsend} {
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} {secureserver testsend} {
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]
test send-12.1 {TimeoutProc procedure} {secureserver testsend} {
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}}
catch {testsend prop root InterpRegistry ""}
test send-12.2 {TimeoutProc procedure} {secureserver} {
winfo interps
tk appname tktest
update
setupbg
set app [dobg {
after 10 {after 10 {after 5000; exit}}
tk appname
}]
after 200
set result [list [catch {send $app foo} msg] $msg]
cleanupbg
set result
} {1 {target application died}}
winfo interps
tk appname tktest
test send-13.1 {DeleteProc procedure} {secureserver} {
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} {secureserver} {
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}
test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {secureserver altDisplay} {
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}
catch {
testsend prop root InterpRegister $registry
tk appname tktest
}
test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} {
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}
catch {
tk appname $name
testsend prop root InterpRegistry $registry
testdeleteapps
}
rename newApp {}
# cleanup
cleanupTests
return

3832
tests/spinbox.test Normal file
View File

File diff suppressed because it is too large Load Diff

31
tests/teapot.ppm Normal file
View File

File diff suppressed because one or more lines are too long

7302
tests/text.test Normal file
View File

File diff suppressed because it is too large Load Diff

1247
tests/textBTree.test Normal file
View File

File diff suppressed because it is too large Load Diff

4249
tests/textDisp.test Normal file
View File

File diff suppressed because it is too large Load Diff

473
tests/textImage.test Normal file
View File

@@ -0,0 +1,473 @@
# textImage.test -- test images embedded in text widgets
#
# 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) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit
# One time setup. Create a font to insure the tests are font metric invariant.
destroy .t
font create test_font -family courier -size 14
text .t -font test_font
destroy .t
test textImage-1.1 {basic argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image
} -cleanup {
destroy .t
} -returnCodes error -result {wrong # args: should be ".t image option ?arg ...?"}
test textImage-1.2 {basic argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image c
} -cleanup {
destroy .t
} -returnCodes error -result {ambiguous option "c": must be cget, configure, create, or names}
test textImage-1.3 {cget argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image cget
} -cleanup {
destroy .t
} -returnCodes error -result {wrong # args: should be ".t image cget index option"}
test textImage-1.4 {cget argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image cget blurf -flurp
} -cleanup {
destroy .t
} -returnCodes error -result {bad text index "blurf"}
test textImage-1.5 {cget argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image cget 1.1 -flurp
} -cleanup {
destroy .t
} -returnCodes error -result {no embedded image at index "1.1"}
test textImage-1.6 {configure argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image configure
} -cleanup {
destroy .t
} -returnCodes error -result {wrong # args: should be ".t image configure index ?-option value ...?"}
test textImage-1.7 {configure argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image configure blurf
} -cleanup {
destroy .t
} -returnCodes error -result {bad text index "blurf"}
test textImage-1.8 {configure argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image configure 1.1
} -cleanup {
destroy .t
} -returnCodes error -result {no embedded image at index "1.1"}
test textImage-1.9 {create argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create
} -cleanup {
destroy .t
} -returnCodes error -result {wrong # args: should be ".t image create index ?-option value ...?"}
test textImage-1.10 {create argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create blurf
} -cleanup {
destroy .t
} -returnCodes error -result {bad text index "blurf"}
test textImage-1.11 {basic argument checking} -setup {
destroy .t
} -body {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create 1000.1000 -image small
} -cleanup {
destroy .t
image delete small
} -returnCodes ok -result {small}
test textImage-1.12 {names argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image names dates places
} -cleanup {
destroy .t
} -returnCodes error -result {wrong # args: should be ".t image names"}
test textImage-1.13 {names argument checking} -setup {
destroy .t
set result ""
} -body {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
lappend result [.t image names]
.t image create insert -image small
lappend result [.t image names]
.t image create insert -image small
lappend result [lsort [.t image names]]
.t image create insert -image small -name little
lappend result [lsort [.t image names]]
} -cleanup {
destroy .t
image delete small
} -result {{} small {small small#1} {little small small#1}}
test textImage-1.14 {basic argument checking} -setup {
destroy .t
} -body {
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image huh
} -cleanup {
destroy .t
} -returnCodes error -result {bad option "huh": must be cget, configure, create, or names}
test textImage-1.15 {align argument checking} -setup {
destroy .t
} -body {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image small -align wrong
} -cleanup {
destroy .t
image delete small
} -returnCodes error -result {bad align "wrong": must be baseline, bottom, center, or top}
test textImage-1.16 {configure} -setup {
destroy .t
} -body {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
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
} -cleanup {
destroy .t
image delete small
} -result {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}}
test textImage-1.17 {basic cget options} -setup {
destroy .t
set result ""
} -body {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image small
foreach i {align padx pady image name} {
lappend result $i:[.t image cget small -$i]
}
return $result
} -cleanup {
destroy .t
image delete small
} -result {align:center padx:0 pady:0 image:small name:}
test textImage-1.18 {basic configure options} -setup {
destroy .t
set result ""
} -body {
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
}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image small
foreach {option value} {align top padx 5 pady 7 image large name none} {
.t image configure small -$option $value
}
update
.t image configure small
} -cleanup {
destroy .t
image delete small large
} -result {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}}
test textImage-1.19 {basic image naming} -setup {
destroy .t
} -body {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
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]
} -cleanup {
destroy .t
image delete small
} -result {small small#1 small#6342 small#6343}
test textImage-2.1 {debug} -setup {
destroy .t
} -body {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
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
} -cleanup {
destroy .t
image delete small
} -result {}
test textImage-3.1 {image change propagation} -setup {
destroy .t
set result ""
} -body {
catch {
image create photo vary -width 5 -height 5
vary put red -to 0 0 4 4
}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image vary -align top
update
lappend result base:[.t bbox vary]
foreach i {10 20 40} {
vary configure -width $i -height $i
update
lappend result $i:[.t bbox vary]
}
return $result
} -cleanup {
destroy .t
image delete vary
} -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, see also bug 1591493} -setup {
destroy .t
set result ""
} -body {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -name test
update
foreach {x1 y1 w1 h1} [.t bbox test] {}
lappend result [list $x1 $w1 $h1]
.t image configure test -image small -align top
update
foreach {x2 y2 w2 h2} [.t bbox test] {}
lappend result [list [expr {$x1==$x2}] [expr {$w2>0}] [expr {$h2>0}]]
} -cleanup {
destroy .t
image delete small
} -result {{0 0 0} {1 1 1}}
# some temporary random tests
test textImage-4.1 {alignment checking - except baseline} -setup {
destroy .t
set result ""
} -body {
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
}
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
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]
}
return $result
} -cleanup {
destroy .t
image delete small large
} -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} -setup {
destroy .t
set result ""
} -body {
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
}
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
# Sizes larger than 25 can be too big and lead to a negative 'norm',
# at least on Windows XP with certain settings.
foreach size {10 15 20 25} {
font configure test_font2 -size $size
array set Metrics [font metrics test_font2]
update
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"
}
return $result
} -cleanup {
destroy .t
image delete small large
font delete test_font2
unset Metrics
} -result {{10 0} {15 0} {20 0} {25 0}}
test textImage-4.3 {alignment and padding checking} -constraints {
fonts
} -setup {
destroy .t
set result ""
} -body {
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
}
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
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]
}
return $result
} -cleanup {
destroy .t
image delete small large
} -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}}
test textImage-5.1 {peer widget images} -setup {
destroy .t .tt
} -body {
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
}
pack [text .t]
toplevel .tt
pack [.t peer create .tt.t]
.t image create end -image large
.t image create end -image small -padx 5 -pady 10
.t insert end test
update
destroy .t .tt
} -cleanup {
image delete small large
} -result {}
# cleanup
destroy .t
font delete test_font
imageFinish
# cleanup
cleanupTests
return
# Local variables:
# mode: tcl
# End:

963
tests/textIndex.test Normal file
View File

@@ -0,0 +1,963 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
catch {destroy .t}
text .t -font {Courier -12} -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 .
.t insert 1.0 "Line 1
abcdefghijklm
12345
Line 4
b\u4e4fy GIrl .#@? x_yz
!@#$%
Line 7"
image create photo textimage -width 10 -height 10
textimage put red -to 0 0 9 9
test textIndex-1.1 {TkTextMakeByteIndex} {testtext} {
# (lineIndex < 0)
testtext .t byteindex -1 3
} {1.0 0}
test textIndex-1.2 {TkTextMakeByteIndex} {testtext} {
# (lineIndex < 0), because lineIndex == strtol(argv[2]) - 1
testtext .t byteindex 0 3
} {1.0 0}
test textIndex-1.3 {TkTextMakeByteIndex} {testtext} {
# not (lineIndex < 0)
testtext .t byteindex 1 3
} {1.3 3}
test textIndex-1.4 {TkTextMakeByteIndex} {testtext} {
# (byteIndex < 0)
testtext .t byteindex 3 -1
} {3.0 0}
test textIndex-1.5 {TkTextMakeByteIndex} {testtext} {
# not (byteIndex < 0)
testtext .t byteindex 3 3
} {3.3 3}
test textIndex-1.6 {TkTextMakeByteIndex} {testtext} {
# (indexPtr->linePtr == NULL)
testtext .t byteindex 9 2
} {8.0 0}
test textIndex-1.7 {TkTextMakeByteIndex} {testtext} {
# not (indexPtr->linePtr == NULL)
testtext .t byteindex 7 2
} {7.2 2}
test textIndex-1.8 {TkTextMakeByteIndex: shortcut for 0} {testtext} {
# (byteIndex == 0)
testtext .t byteindex 1 0
} {1.0 0}
test textIndex-1.9 {TkTextMakeByteIndex: shortcut for 0} {testtext} {
# not (byteIndex == 0)
testtext .t byteindex 3 80
} {3.5 5}
test textIndex-1.10 {TkTextMakeByteIndex: verify index is in range} {testtext} {
# for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
# one segment
testtext .t byteindex 3 5
} {3.5 5}
test textIndex-1.11 {TkTextMakeByteIndex: verify index is in range} {testtext} {
# for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
# index += segPtr->size
# Multiple segments, make sure add segment size to index.
.t mark set foo 3.2
set x [testtext .t byteindex 3 7]
.t mark unset foo
set x
} {3.5 5}
test textIndex-1.12 {TkTextMakeByteIndex: verify index is in range} {testtext} {
# (segPtr == NULL)
testtext .t byteindex 3 7
} {3.5 5}
test textIndex-1.13 {TkTextMakeByteIndex: verify index is in range} {testtext} {
# not (segPtr == NULL)
testtext .t byteindex 3 4
} {3.4 4}
test textIndex-1.14 {TkTextMakeByteIndex: verify index is in range} {testtext} {
# (index + segPtr->size > byteIndex)
# in this segment.
testtext .t byteindex 3 4
} {3.4 4}
test textIndex-1.15 {TkTextMakeByteIndex: verify index is in range} {testtext} {
# (index + segPtr->size > byteIndex), index != 0
# in this segment.
.t mark set foo 3.2
set x [testtext .t byteindex 3 4]
.t mark unset foo
set x
} {3.4 4}
test textIndex-1.16 {TkTextMakeByteIndex: UTF-8 characters} {testtext} {
testtext .t byteindex 5 100
} {5.18 20}
test textIndex-1.17 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \
{testtext} {
# ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType))
# Wrong answer would be \xb9 (the 2nd byte of UTF rep of 0x4e4f).
set x [testtext .t byteindex 5 2]
list $x [.t get insert]
} {{5.2 4} y}
test textIndex-1.18 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \
{testtext} {
# ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType))
testtext .t byteindex 5 1
.t get insert
} "\u4e4f"
test textIndex-2.1 {TkTextMakeCharIndex} {
# (lineIndex < 0)
.t index -1.3
} 1.0
test textIndex-2.2 {TkTextMakeCharIndex} {
# (lineIndex < 0), because lineIndex == strtol(argv[2]) - 1
.t index 0.3
} 1.0
test textIndex-2.3 {TkTextMakeCharIndex} {
# not (lineIndex < 0)
.t index 1.3
} 1.3
test textIndex-2.4 {TkTextMakeCharIndex} {
# (charIndex < 0)
.t index 3.-1
} 3.0
test textIndex-2.5 {TkTextMakeCharIndex} {
# (charIndex < 0)
.t index 3.3
} 3.3
test textIndex-2.6 {TkTextMakeCharIndex} {
# (indexPtr->linePtr == NULL)
.t index 9.2
} 8.0
test textIndex-2.7 {TkTextMakeCharIndex} {
# not (indexPtr->linePtr == NULL)
.t index 7.2
} 7.2
test textIndex-2.8 {TkTextMakeCharIndex: verify index is in range} {
# for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
# one segment
.t index 3.5
} 3.5
test textIndex-2.9 {TkTextMakeCharIndex: verify index is in range} {
# for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
# Multiple segments, make sure add segment size to index.
.t mark set foo 3.2
set x [.t index 3.7]
.t mark unset foo
set x
} 3.5
test textIndex-2.10 {TkTextMakeCharIndex: verify index is in range} {
# (segPtr == NULL)
.t index 3.7
} 3.5
test textIndex-2.11 {TkTextMakeCharIndex: verify index is in range} {
# not (segPtr == NULL)
.t index 3.4
} 3.4
test textIndex-2.12 {TkTextMakeCharIndex: verify index is in range} {
# (segPtr->typePtr == &tkTextCharType)
# Wrong answer would be \xb9 (the 2nd byte of UTF rep of 0x4e4f).
.t mark set insert 5.2
.t get insert
} y
test textIndex-2.13 {TkTextMakeCharIndex: verify index is in range} {
# not (segPtr->typePtr == &tkTextCharType)
.t image create 5.2 -image textimage
.t mark set insert 5.5
set x [.t get insert]
.t delete 5.2
set x
} "G"
test textIndex-2.14 {TkTextMakeCharIndex: verify index is in range} {
# (charIndex < segPtr->size)
.t image create 5.0 -image textimage
set x [.t index 5.0]
.t delete 5.0
set x
} 5.0
.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
set weirdImage "foo-1"
.t image create 2.1 -image [image create photo $weirdImage]
set weirdEmbWin ".t.bar-1"
entry $weirdEmbWin
.t window create 3.1 -window $weirdEmbWin
test textIndex-3.1 {TkTextGetIndex, weird mark names} {
list [catch {.t index $weirdMark} msg] $msg
} {0 4.0}
test textIndex-3.2 {TkTextGetIndex, weird mark names} knownBug {
list [catch {.t index "$weirdMark -1char"} msg] $msg
} {0 4.0}
test textIndex-3.3 {TkTextGetIndex, weird embedded window names} {
list [catch {.t index $weirdEmbWin} msg] $msg
} {0 3.1}
test textIndex-3.4 {TkTextGetIndex, weird embedded window names} knownBug {
list [catch {.t index "$weirdEmbWin -1char"} msg] $msg
} {0 3.0}
test textIndex-3.5 {TkTextGetIndex, weird image names} {
list [catch {.t index $weirdImage} msg] $msg
} {0 2.1}
test textIndex-3.6 {TkTextGetIndex, weird image names} knownBug {
list [catch {.t index "$weirdImage -1char"} msg] $msg
} {0 2.0}
.t delete 3.1 ; # remove the weirdEmbWin
.t delete 2.1 ; # remove the weirdImage
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, "@"} {nonPortable 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 {1.3 + 3 lines}} msg] $msg
} {0 4.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-10.9 {ForwBack} {
.t mark set insert 2.0
list [catch {.t index {insert -0 chars}} msg] $msg
} {0 2.0}
test textIndex-10.10 {ForwBack} {
.t mark set insert 2.end
list [catch {.t index {insert +0 chars}} msg] $msg
} {0 2.13}
test textIndex-11.1 {TkTextIndexForwBytes} {testtext} {
testtext .t forwbytes 2.3 -7
} {1.3 3}
test textIndex-11.2 {TkTextIndexForwBytes} {testtext} {
testtext .t forwbytes 2.3 5
} {2.8 8}
test textIndex-11.3 {TkTextIndexForwBytes} {testtext} {
testtext .t forwbytes 2.3 10
} {2.13 13}
test textIndex-11.4 {TkTextIndexForwBytes} {testtext} {
testtext .t forwbytes 2.3 11
} {3.0 0}
test textIndex-11.5 {TkTextIndexForwBytes} {testtext} {
testtext .t forwbytes 2.3 57
} {7.6 6}
test textIndex-11.6 {TkTextIndexForwBytes} {testtext} {
testtext .t forwbytes 2.3 58
} {8.0 0}
test textIndex-11.7 {TkTextIndexForwBytes} {testtext} {
testtext .t forwbytes 2.3 59
} {8.0 0}
test textIndex-12.1 {TkTextIndexForwChars} {
# (charCount < 0)
.t index {2.3 + -7 chars}
} 1.3
test textIndex-12.2 {TkTextIndexForwChars} {
# not (charCount < 0)
.t index {2.3 + 5 chars}
} 2.8
test textIndex-12.3 {TkTextIndexForwChars: find index} {
# for ( ; segPtr != NULL; segPtr = segPtr->nextPtr)
# one loop
.t index {2.3 + 9 chars}
} 2.12
test textIndex-12.4 {TkTextIndexForwChars: find index} {
# for ( ; segPtr != NULL; segPtr = segPtr->nextPtr)
# multiple loops
.t mark set foo 2.5
set x [.t index {2.3 + 9 chars}]
.t mark unset foo
set x
} 2.12
test textIndex-12.5 {TkTextIndexForwChars: find index} {
# for ( ; segPtr != NULL; segPtr = segPtr->nextPtr)
# border condition: last char
.t index {2.3 + 10 chars}
} 2.13
test textIndex-12.6 {TkTextIndexForwChars: find index} {
# for ( ; segPtr != NULL; segPtr = segPtr->nextPtr)
# border condition: segPtr == NULL -> beginning of next line
.t index {2.3 + 11 chars}
} 3.0
test textIndex-12.7 {TkTextIndexForwChars: find index} {
# (segPtr->typePtr == &tkTextCharType)
.t index {2.3 + 2 chars}
} 2.5
test textIndex-12.8 {TkTextIndexForwChars: find index} {
# (charCount == 0)
# No more chars, so we found byte offset.
.t index {2.3 + 2 chars}
} 2.5
test textIndex-12.9 {TkTextIndexForwChars: find index} {
# not (segPtr->typePtr == &tkTextCharType)
.t image create 2.4 -image textimage
set x [.t get {2.3 + 3 chars}]
.t delete 2.4
set x
} "f"
test textIndex-12.10 {TkTextIndexForwChars: find index} {
# dstPtr->byteIndex += segPtr->size - byteOffset
# When moving to next segment, account for bytes in last segment.
# Wrong answer would be 2.4
.t mark set foo 2.4
set x [.t index {2.3 + 5 chars}]
.t mark unset foo
set x
} 2.8
test textIndex-12.11 {TkTextIndexForwChars: go to next line} {
# (linePtr == NULL)
.t index {7.6 + 3 chars}
} 8.0
test textIndex-12.12 {TkTextIndexForwChars: go to next line} {
# Reset byteIndex to 0 now that we are on a new line.
# Wrong answer would be 2.9
.t index {1.3 + 6 chars}
} 2.2
test textIndex-12.13 {TkTextIndexForwChars} {
# right to end
.t index {2.3 + 56 chars}
} 8.0
test textIndex-12.14 {TkTextIndexForwChars} {
# try to go past end
.t index {2.3 + 57 chars}
} 8.0
test textIndex-13.1 {TkTextIndexBackBytes} {testtext} {
testtext .t backbytes 3.2 -10
} {4.6 6}
test textIndex-13.2 {TkTextIndexBackBytes} {testtext} {
testtext .t backbytes 3.2 2
} {3.0 0}
test textIndex-13.3 {TkTextIndexBackBytes} {testtext} {
testtext .t backbytes 3.2 3
} {2.13 13}
test textIndex-13.4 {TkTextIndexBackBytes} {testtext} {
testtext .t backbytes 3.2 22
} {1.1 1}
test textIndex-13.5 {TkTextIndexBackBytes} {testtext} {
testtext .t backbytes 3.2 23
} {1.0 0}
test textIndex-13.6 {TkTextIndexBackBytes} {testtext} {
testtext .t backbytes 3.2 24
} {1.0 0}
test textIndex-14.1 {TkTextIndexBackChars} {
# (charCount < 0)
.t index {3.2 - -10 chars}
} 4.6
test textIndex-14.2 {TkTextIndexBackChars} {
# not (charCount < 0)
.t index {3.2 - 2 chars}
} 3.0
test textIndex-14.3 {TkTextIndexBackChars: find starting segment} {
# for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
# single loop
.t index {3.2 - 3 chars}
} 2.13
test textIndex-14.4 {TkTextIndexBackChars: find starting segment} {
# for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
# multiple loop
.t mark set foo1 2.5
.t mark set foo2 2.7
.t mark set foo3 2.10
set x [.t index {2.9 - 1 chars}]
.t mark unset foo1 foo2 foo3
set x
} 2.8
test textIndex-14.5 {TkTextIndexBackChars: find starting seg and offset} {
# for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
# Make sure segSize was decremented. Wrong answer would be 2.10
.t mark set foo 2.2
set x [.t index {2.9 - 1 char}]
.t mark unset foo
set x
} 2.8
test textIndex-14.6 {TkTextIndexBackChars: back over characters} {
# (segPtr->typePtr == &tkTextCharType)
.t index {3.2 - 22 chars}
} 1.1
test textIndex-14.7 {TkTextIndexBackChars: loop backwards over chars} {
# (charCount == 0)
# No more chars, so we found byte offset.
.t index {3.4 - 2 chars}
} 3.2
test textIndex-14.8 {TkTextIndexBackChars: loop backwards over chars} {
# (p == start)
# Still more chars, but we reached beginning of segment
.t image create 5.6 -image textimage
set x [.t index {5.8 - 3 chars}]
.t delete 5.6
set x
} 5.5
test textIndex-14.9 {TkTextIndexBackChars: back over image} {
# not (segPtr->typePtr == &tkTextCharType)
.t image create 5.6 -image textimage
set x [.t get {5.8 - 4 chars}]
.t delete 5.6
set x
} "G"
test textIndex-14.10 {TkTextIndexBackChars: move to previous segment} {
# (segPtr != oldPtr)
# More segments to go
.t mark set foo 3.4
set x [.t index {3.5 - 2 chars}]
.t mark unset foo
set x
} 3.3
test textIndex-14.11 {TkTextIndexBackChars: move to previous segment} {
# not (segPtr != oldPtr)
# At beginning of line.
.t mark set foo 3.4
set x [.t index {3.5 - 10 chars}]
.t mark unset foo
set x
} 2.9
test textIndex-14.12 {TkTextIndexBackChars: move to previous line} {
# (lineIndex == 0)
.t index {1.5 - 10 chars}
} 1.0
test textIndex-14.13 {TkTextIndexBackChars: move to previous line} {
# not (lineIndex == 0)
.t index {2.5 - 10 chars}
} 1.2
test textIndex-14.14 {TkTextIndexBackChars: move to previous line} {
# for (segPtr = oldPtr; segPtr != NULL; segPtr = segPtr->nextPtr)
# Set byteIndex to end of previous line so we can subtract more
# bytes from it. Otherwise we get an TkTextIndex with a negative
# byteIndex.
.t index {2.5 - 6 chars}
} 1.6
test textIndex-14.15 {TkTextIndexBackChars: UTF} {
.t get {5.3 - 1 chars}
} y
test textIndex-14.16 {TkTextIndexBackChars: UTF} {
.t get {5.3 - 2 chars}
} \u4e4f
test textIndex-14.17 {TkTextIndexBackChars: UTF} {
.t get {5.3 - 3 chars}
} b
proc getword index {
.t get [.t index "$index wordstart"] [.t index "$index wordend"]
}
test textIndex-15.1 {StartEnd} {
list [catch {.t index {2.3 lineend}} msg] $msg
} {0 2.13}
test textIndex-15.2 {StartEnd} {
list [catch {.t index {2.3 linee}} msg] $msg
} {0 2.13}
test textIndex-15.3 {StartEnd} {
list [catch {.t index {2.3 line}} msg] $msg
} {1 {bad text index "2.3 line"}}
test textIndex-15.4 {StartEnd} {
list [catch {.t index {2.3 linestart}} msg] $msg
} {0 2.0}
test textIndex-15.5 {StartEnd} {
list [catch {.t index {2.3 lines}} msg] $msg
} {0 2.0}
test textIndex-15.6 {StartEnd} {
getword 5.3
} { }
test textIndex-15.7 {StartEnd} {
getword 5.4
} GIrl
test textIndex-15.8 {StartEnd} {
getword 5.7
} GIrl
test textIndex-15.9 {StartEnd} {
getword 5.8
} { }
test textIndex-15.10 {StartEnd} {
getword 5.14
} x_yz
test textIndex-15.11 {StartEnd} {
getword 6.2
} #
test textIndex-15.12 {StartEnd} {
getword 3.4
} 12345
.t tag add x 2.8 2.11
test textIndex-15.13 {StartEnd} {
list [catch {.t index {2.2 worde}} msg] $msg
} {0 2.13}
test textIndex-15.14 {StartEnd} {
list [catch {.t index {2.12 words}} msg] $msg
} {0 2.0}
test textIndex-15.15 {StartEnd} {
list [catch {.t index {2.12 word}} msg] $msg
} {1 {bad text index "2.12 word"}}
test textIndex-16.1 {TkTextPrintIndex} {
set t [text .t2]
$t insert end \n
$t window create end -window [button $t.b]
set result [$t index end-2c]
pack $t
catch {destroy $t}
} 0
test textIndex-16.2 {TkTextPrintIndex} {
set t [text .t2]
$t insert end \n
$t window create end -window [button $t.b]
set result [$t tag add {} end-2c]
pack $t
catch {destroy $t}
} 0
test textIndex-17.1 {Object indices} {
set res {}
set t [text .t2 -height 20]
for {set i 0} {$i < 100} {incr i} {
$t insert end $i\n
}
pack $t
update
set idx @0,0
lappend res $idx [$t index $idx]
$t yview scroll 2 pages
lappend res $idx [$t index $idx]
catch {destroy $t}
unset i
unset idx
list $res
} {{@0,0 1.0 @0,0 37.0}}
test textIndex-18.1 {Object indices don't cache mark names} {
set res {}
text .t2
.t2 insert 1.0 1234\n1234\n1234
set pos "insert"
lappend res [.t2 index $pos]
.t2 mark set $pos 3.0
lappend res [.t2 index $pos]
.t2 mark set $pos 1.0
lappend res [.t2 index $pos]
catch {destroy .t2}
set res
} {3.4 3.0 1.0}
frame .f -width 100 -height 20
pack append . .f left
set fixedFont {Courier -12}
set fixedHeight [font metrics $fixedFont -linespace]
set fixedWidth [font measure $fixedFont m]
set varFont {Times -14}
set bigFont {Helvetica -24}
destroy .t
text .t -font $fixedFont -width 20 -height 10 -wrap char
pack append . .t {top expand fill}
.t tag configure big -font $bigFont
.t debug on
wm geometry . {}
# The statements below reset the main window; it's needed if the window
# manager is mwm to make mwm forget about a previous minimum size setting.
wm withdraw .
wm minsize . 1 1
wm positionfrom . user
wm deiconify .
update
# Some window managers (like olwm under SunOS 4.1.3) misbehave in a way
# that tends to march windows off the top and left of the screen. If
# this happens, some tests will fail because parts of the window will
# not need to be displayed (because they're off-screen). To keep this
# from happening, move the window if it's getting near the left or top
# edges of the screen.
if {([winfo rooty .] < 50) || ([winfo rootx .] < 50)} {
wm geom . +50+50
}
set str [string repeat "hello " 20]
.t insert end "$str one two three four five six seven height nine ten\n"
.t insert end "$str one two three four five six seven height nine ten\n"
.t insert end "$str one two three four five six seven height nine ten\n"
test textIndex-19.1 {Display lines} {
.t index "2.7 displaylinestart"
} {2.0}
test textIndex-19.2 {Display lines} {
.t index "2.7 displaylineend"
} {2.19}
test textIndex-19.3 {Display lines} {
.t index "2.30 displaylinestart"
} {2.20}
test textIndex-19.4 {Display lines} {
.t index "2.30 displaylineend"
} {2.39}
test textIndex-19.5 {Display lines} {
.t index "2.40 displaylinestart"
} {2.40}
test textIndex-19.6 {Display lines} {
.t index "2.40 displaylineend"
} {2.59}
test textIndex-19.7 {Display lines} {
.t index "2.7 +1displaylines"
} {2.27}
test textIndex-19.8 {Display lines} {
.t index "2.7 -1displaylines"
} {1.167}
test textIndex-19.9 {Display lines} {
.t index "2.30 +1displaylines"
} {2.50}
test textIndex-19.10 {Display lines} {
.t index "2.30 -1displaylines"
} {2.10}
test textIndex-19.11 {Display lines} {
.t index "2.40 +1displaylines"
} {2.60}
test textIndex-19.12 {Display lines} {
.t index "2.40 -1displaylines"
} {2.20}
test textIndex-19.13 {Display lines} {
destroy {*}[pack slaves .]
text .txt -height 1 -wrap word -yscroll ".sbar set" -width 400
scrollbar .sbar -command ".txt yview"
grid .txt .sbar -sticky news
grid configure .sbar -sticky ns
grid rowconfigure . 0 -weight 1
grid columnconfigure . 0 -weight 1
.txt configure -width 10
.txt tag config STAMP -elide 1
.txt tag config NICK-tick -elide 0
.txt insert end "+++++ Loading History ++++++++++++++++\n"
.txt mark set HISTORY {2.0 - 1 line}
.txt insert HISTORY { } STAMP
.txt insert HISTORY {tick } {NICK NICK-tick}
.txt insert HISTORY "\n" {NICK NICK-tick}
.txt insert HISTORY {[23:51] } STAMP
.txt insert HISTORY "\n" {NICK NICK-tick}
# Must not crash
.txt index "2.0 - 2 display lines"
destroy .txt .sbar
} {}
proc text_test_word {startend chars start} {
destroy .t
text .t
.t insert end $chars
if {[regexp {end} $start]} {
set start [.t index "${start}chars -2c"]
} else {
set start [.t index "1.0 + ${start}chars"]
}
if {[.t compare $start >= "end-1c"]} {
set start "end-2c"
}
set res [.t index "$start $startend"]
.t count 1.0 $res
}
# Following tests copied from tests from string wordstart/end in Tcl
test textIndex-21.4 {text index wordend} {
text_test_word wordend abc. -1
} 3
test textIndex-21.5 {text index wordend} {
text_test_word wordend abc. 100
} 4
test textIndex-21.6 {text index wordend} {
text_test_word wordend "word_one two three" 2
} 8
test textIndex-21.7 {text index wordend} {
text_test_word wordend "one .&# three" 5
} 6
test textIndex-21.8 {text index wordend} {
text_test_word worde "x.y" 0
} 1
test textIndex-21.9 {text index wordend} {
text_test_word worde "x.y" end-1
} 2
test textIndex-21.10 {text index wordend, unicode} {
text_test_word wordend "xyz\u00c7de fg" 0
} 6
test textIndex-21.11 {text index wordend, unicode} {
text_test_word wordend "xyz\uc700de fg" 0
} 6
test textIndex-21.12 {text index wordend, unicode} {
text_test_word wordend "xyz\u203fde fg" 0
} 6
test textIndex-21.13 {text index wordend, unicode} {
text_test_word wordend "xyz\u2045de fg" 0
} 3
test textIndex-21.14 {text index wordend, unicode} {
text_test_word wordend "\uc700\uc700 abc" 8
} 6
test textIndex-22.5 {text index wordstart} {
text_test_word wordstart "one two three_words" 400
} 8
test textIndex-22.6 {text index wordstart} {
text_test_word wordstart "one two three_words" 2
} 0
test textIndex-22.7 {text index wordstart} {
text_test_word wordstart "one two three_words" -2
} 0
test textIndex-22.8 {text index wordstart} {
text_test_word wordstart "one .*&^ three" 6
} 6
test textIndex-22.9 {text index wordstart} {
text_test_word wordstart "one two three" 4
} 4
test textIndex-22.10 {text index wordstart} {
text_test_word wordstart "one two three" end-5
} 7
test textIndex-22.11 {text index wordstart, unicode} {
text_test_word wordstart "one tw\u00c7o three" 7
} 4
test textIndex-22.12 {text index wordstart, unicode} {
text_test_word wordstart "ab\uc700\uc700 cdef ghi" 12
} 10
test textIndex-22.13 {text index wordstart, unicode} {
text_test_word wordstart "\uc700\uc700 abc" 8
} 3
test textIndex-22.14 {text index wordstart, unicode, start index at internal segment start} {
catch {destroy .t}
text .t
.t insert end "C'est du texte en fran\u00e7ais\n"
.t insert end "\u042D\u0442\u043E\u0020\u0442\u0435\u043A\u0441\u0442\u0020\u043D\u0430\u0020\u0440\u0443\u0441\u0441\u043A\u043E\u043C"
.t mark set insert 1.23
set res [.t index "1.23 wordstart"]
.t mark set insert 2.16
lappend res [.t index "2.16 wordstart"] [.t index "2.15 wordstart"]
} {1.18 2.13 2.13}
test textIndex-22.15 {text index display wordstart} {
catch {destroy .t}
text .t
.t index "1.0 display wordstart" ; # used to crash
} 1.0
test textIndex-23.1 {text paragraph start} {
pack [text .t2]
.t2 insert end " Text"
set res 2.0
for {set i 0} {$i < 2} {incr i} {
lappend res [::tk::TextPrevPara .t2 [lindex $res end]]
}
destroy .t2
set res
} {2.0 1.1 1.1}
test textIndex-24.1 {text mark prev} {
pack [text .t2]
.t2 insert end [string repeat "1 2 3 4 5 6 7 8 9 0\n" 12]
.t2 mark set 1.0 10.0
update
# then this crash Tk:
set res [.t2 mark previous 10.10]
destroy .t2
set res
} {1.0}
test textIndex-25.1 {IndexCountBytesOrdered, bug [3f1f79abcf]} {
pack [text .t2]
.t2 tag configure elided -elide 1
.t2 insert end "01\n02\n03\n04\n05\n06\n07\n08\n09\n10\n"
.t2 insert end "11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n"
.t2 insert end "21\n22\n23\n25\n26\n27\n28\n29\n30\n31"
.t2 insert end "32\n33\n34\n36\n37\n38\n39" elided
# then this used to crash Tk:
.t2 see end
focus -force .t2 ; # to see the cursor blink
destroy .t2
} {}
# cleanup
rename textimage {}
catch {destroy .t}
cleanupTests
return

306
tests/textMark.test Normal file
View File

@@ -0,0 +1,306 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
destroy .t
text .t -width 20 -height 10
pack append . .t {top expand fill}
update
.t debug on
wm geometry . {}
entry .t.e
.t peer create .pt
.t insert 1.0 "Line 1
abcdefghijklm
12345
Line 4
bOy GIrl .#@? x_yz
!@#$%
Line 7"
# 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 textMark-1.1 {TkTextMarkCmd - missing option} -returnCodes error -body {
.t mark
} -result {wrong # args: should be ".t mark option ?arg ...?"}
test textMark-1.2 {TkTextMarkCmd - bogus option} -returnCodes error -body {
.t mark gorp
} -match glob -result {bad mark option "gorp": must be *}
test textMark-1.3 {TkTextMarkCmd - "gravity" option} -returnCodes error -body {
.t mark gravity foo
} -result {there is no mark named "foo"}
test textMark-1.4 {TkTextMarkCmd - "gravity" option} -body {
.t mark set x 1.3
.t insert 1.3 x
list [.t mark gravity x] [.t index x]
} -result {right 1.4}
test textMark-1.5 {TkTextMarkCmd - "gravity" option} -body {
.t mark set x 1.3
.t mark g x left
.t insert 1.3 x
list [.t mark gravity x] [.t index x]
} -result {left 1.3}
test textMark-1.6 {TkTextMarkCmd - "gravity" option} -body {
.t mark set x 1.3
.t mark gravity x right
.t insert 1.3 x
list [.t mark gravity x] [.t index x]
} -result {right 1.4}
test textMark-1.7 {TkTextMarkCmd - "gravity" option} -returnCodes error -body {
.t mark set x 1.3
.t mark gravity x gorp
} -result {bad mark gravity "gorp": must be left or right}
test textMark-1.8 {TkTextMarkCmd - "gravity" option} -returnCodes error -body {
.t mark gravity
} -result {wrong # args: should be ".t mark gravity markName ?gravity?"}
test textMark-2.1 {TkTextMarkCmd - "names" option} -body {
.t mark names 2
} -returnCodes error -result {wrong # args: should be ".t mark names"}
test textMark-2.2 {TkTextMarkCmd - "names" option} -setup {
.t mark unset {*}[.t mark names]
} -body {
lsort [.t mark na]
} -result {current insert}
test textMark-2.3 {TkTextMarkCmd - "names" option} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set a 1.1
.t mark set "b c" 2.3
lsort [.t mark names]
} -result {a {b c} current insert}
test textMark-3.1 {TkTextMarkCmd - "set" option} -returnCodes error -body {
.t mark set a
} -result {wrong # args: should be ".t mark set markName index"}
test textMark-3.2 {TkTextMarkCmd - "set" option} -returnCodes error -body {
.t mark s a b c
} -result {wrong # args: should be ".t mark set markName index"}
test textMark-3.3 {TkTextMarkCmd - "set" option} -body {
.t mark set a @x
} -returnCodes error -result {bad text index "@x"}
test textMark-3.4 {TkTextMarkCmd - "set" option} -body {
.t mark set a 1.2
.t index a
} -result 1.2
test textMark-3.5 {TkTextMarkCmd - "set" option} -body {
.t mark set a end
.t index a
} -result {8.0}
test textMark-4.1 {TkTextMarkCmd - "unset" option} -body {
.t mark unset
} -result {}
test textMark-4.2 {TkTextMarkCmd - "unset" option} -body {
.t mark set a 1.2
.t mark set b 2.3
.t mark unset a b
.t index a
} -returnCodes error -result {bad text index "a"}
test textMark-4.2.1 {TkTextMarkCmd - "unset" option} -body {
.t mark set a 1.2
.t mark set b 2.3
.t mark unset a b
.t index b
} -returnCodes error -result {bad text index "b"}
test textMark-4.3 {TkTextMarkCmd - "unset" option} -body {
.t mark set a 1.2
.t mark set b 2.3
.t mark set 49ers 3.1
.t mark unset {*}[.t mark names]
lsort [.t mark names]
} -result {current insert}
test textMark-5.1 {TkTextMarkCmd - miscellaneous} -returnCodes error -body {
.t mark
} -result {wrong # args: should be ".t mark option ?arg ...?"}
test textMark-5.2 {TkTextMarkCmd - miscellaneous} -returnCodes error -body {
.t mark foo
} -result {bad mark option "foo": must be gravity, names, next, previous, set, or unset}
test textMark-6.1 {TkTextMarkSegToIndex} -body {
.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]
} -result {1.2 1.2 1.2 1.4}
test textMark-6.2 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body {
.t mark set insert 1.0
.t configure -startline 2
set res [list [.t index insert] [.t index insert-1c] [.t get insert]]
.t mark set insert end
.t configure -endline 4
lappend res [.t index insert]
} -cleanup {
.t configure -startline {} -endline {}
} -result {1.0 1.0 a 2.5}
test textMark-6.3 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body {
.t mark set mymark 1.0
.t configure -startline 2
list [catch {.t index mymark} msg] $msg
} -cleanup {
.t configure -startline {} -endline {}
.t mark unset mymark
} -result {1 {bad text index "mymark"}}
test textMark-6.4 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body {
.t mark set mymark 1.0
.t configure -startline 2
set res [list [catch {.t index mymark} msg] $msg]
lappend res [.pt index mymark]
.t configure -startline {}
.pt configure -startline 4
lappend res [.t index mymark]
lappend res [catch {.pt index mymark} msg] $msg
lappend res [.t get mymark]
lappend res [catch {.pt get mymark} msg] $msg
} -cleanup {
.t configure -startline {} -endline {}
.pt configure -startline {} -endline {}
.t mark unset mymark
} -result {1 {bad text index "mymark"} 1.0 1.0 1 {bad text index "mymark"} L 1 {bad text index "mymark"}}
test textMark-6.5 {insert and current marks in an empty peer - bug 3487407} -body {
.t mark set insert 1.0
.t configure -start 5 -end 5
set res [.t index insert]
} -cleanup {
.t configure -startline {} -endline {}
} -result {1.0}
test textMark-7.1 {MarkFindNext - invalid mark name} -body {
.t mark next bogus
} -returnCodes error -result {bad text index "bogus"}
test textMark-7.2 {MarkFindNext - marks at same location} -body {
.t mark set insert 2.0
.t mark set current 2.0
.t mark next current
} -result {insert}
test textMark-7.3 {MarkFindNext - numerical starting mark} -body {
.t mark set current 1.0
.t mark set insert 1.0
.t mark next 1.0
} -result {insert}
test textMark-7.4 {MarkFindNext - mark on the same line} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current 1.0
.t mark set insert 1.1
.t mark next current
} -result {insert}
test textMark-7.5 {MarkFindNext - mark on the next line} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current 1.end
.t mark set insert 2.0
.t mark next current
} -result {insert}
test textMark-7.6 {MarkFindNext - mark far away} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current 1.2
.t mark set insert 7.0
.t mark next current
} -result {insert}
test textMark-7.7 {MarkFindNext - mark on top of end} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current end
.t mark next end
} -result {current}
test textMark-7.8 {MarkFindNext - no next mark} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current 1.0
.t mark set insert 3.0
.t mark next insert
} -result {}
test textMark-7.9 {MarkFindNext - mark set in a text widget and retrieved from a peer} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set mymark 1.0
lsort [list [.pt mark next 1.0] [.pt mark next mymark] [.pt mark next insert]]
} -result {current insert mymark}
test textMark-8.1 {MarkFindPrev - invalid mark name} -body {
.t mark prev bogus
} -returnCodes error -result {bad text index "bogus"}
test textMark-8.2 {MarkFindPrev - marks at same location} -body {
.t mark set insert 2.0
.t mark set current 2.0
.t mark prev insert
} -result {current}
test textMark-8.3 {MarkFindPrev - numerical starting mark} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current 1.0
.t mark set insert 1.0
.t mark prev 1.1
} -result {current}
test textMark-8.4 {MarkFindPrev - mark on the same line} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current 1.0
.t mark set insert 1.1
.t mark prev insert
} -result {current}
test textMark-8.5 {MarkFindPrev - mark on the previous line} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current 1.end
.t mark set insert 2.0
.t mark prev insert
} -result {current}
test textMark-8.6 {MarkFindPrev - mark far away} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current 1.2
.t mark set insert 7.0
.t mark prev insert
} -result {current}
test textMark-8.7 {MarkFindPrev - mark on top of end} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set insert 3.0
.t mark set current end
.t mark prev end
} -result {insert}
test textMark-8.8 {MarkFindPrev - no previous mark} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set current 1.0
.t mark set insert 3.0
.t mark prev current
} -result {}
test textMark-8.9 {MarkFindPrev - mark set in a text widget and retrieved from a peer} -setup {
.t mark unset {*}[.t mark names]
} -body {
.t mark set mymark 1.0
lsort [list [.pt mark prev end] [.pt mark prev current] [.pt mark prev insert]]
} -result {current insert mymark}
destroy .pt
destroy .t
# cleanup
cleanupTests
return
# Local Variables:
# mode: tcl
# End:

1775
tests/textTag.test Normal file
View File

File diff suppressed because it is too large Load Diff

1482
tests/textWind.test Normal file
View File

File diff suppressed because it is too large Load Diff

184
tests/tk.test Normal file
View File

@@ -0,0 +1,184 @@
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2002 ActiveState Corporation.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
test tk-1.1 {tk command: general} -body {
tk
} -returnCodes error -result {wrong # args: should be "tk subcommand ?arg ...?"}
test tk-1.2 {tk command: general} -body {
tk xyz
} -returnCodes error -result {unknown or ambiguous subcommand "xyz": must be appname, busy, caret, fontchooser, inactive, scaling, useinputmethods, or windowingsystem}
# Value stored to restore default settings after 2.* tests
set appname [tk appname]
test tk-2.1 {tk command: appname} -body {
tk appname xyz abc
} -returnCodes error -result {wrong # args: should be "tk appname ?newName?"}
test tk-2.2 {tk command: appname} -body {
tk appname foobazgarply
} -result {foobazgarply}
test tk-2.3 {tk command: appname} -constraints unix -body {
tk appname bazfoogarply
expr {[lsearch -exact [winfo interps] [tk appname]] >= 0}
} -result {1}
test tk-2.4 {tk command: appname} -body {
tk appname [tk appname]
} -result [tk appname]
tk appname $appname
# Value stored to restore default settings after 3.* tests
set scaling [tk scaling]
test tk-3.1 {tk command: scaling} -body {
tk scaling -displayof
} -returnCodes error -result {value for "-displayof" missing}
test tk-3.2 {tk command: scaling: get current} -body {
tk scaling 1
format %.2g [tk scaling]
} -result 1
test tk-3.3 {tk command: scaling: get current} -body {
tk scaling -displayof . 1.25
format %.3g [tk scaling]
} -result 1.25
test tk-3.4 {tk command: scaling: set new} -body {
tk scaling xyz
} -returnCodes error -result {expected floating-point number but got "xyz"}
test tk-3.5 {tk command: scaling: set new} -body {
tk scaling -displayof . xyz
} -returnCodes error -result {expected floating-point number but got "xyz"}
test tk-3.6 {tk command: scaling: set new} -body {
tk scaling 1
format %.2g [tk scaling]
} -result 1
test tk-3.7 {tk command: scaling: set new} -body {
tk scaling -displayof . 1.25
format %.3g [tk scaling]
} -result 1.25
test tk-3.8 {tk command: scaling: negative} -body {
tk scaling -1
expr {[tk scaling] > 0}
} -result {1}
test tk-3.9 {tk command: scaling: too big} -body {
tk scaling 1000000
expr {[tk scaling] < 10000}
} -result {1}
test tk-3.10 {tk command: scaling: widthmm} -body {
tk scaling 1.25
expr {int((25.4*[winfo screenwidth .])/(72*1.25) + 0.5) \
- [winfo screenmmwidth .]}
} -result {0}
test tk-3.11 {tk command: scaling: heightmm} -body {
tk scaling 1.25
expr {int((25.4*[winfo screenheight .])/(72*1.25) + 0.5) \
- [winfo screenmmheight .]}
} -result {0}
tk scaling $scaling
# Value stored to restore default settings after 4.* tests
set useim [tk useinputmethods]
test tk-4.1 {tk command: useinputmethods} -body {
tk useinputmethods -displayof
} -returnCodes error -result {value for "-displayof" missing}
test tk-4.2 {tk command: useinputmethods: get current} -body {
tk useinputmethods no
} -cleanup {
tk useinputmethods $useim
} -result 0
test tk-4.3 {tk command: useinputmethods: get current} -body {
tk useinputmethods no
tk useinputmethods -displayof .
} -cleanup {
tk useinputmethods $useim
} -result 0
test tk-4.4 {tk command: useinputmethods: set new} -body {
tk useinputmethods xyz
} -returnCodes error -result {expected boolean value but got "xyz"}
test tk-4.5 {tk command: useinputmethods: set new} -body {
tk useinputmethods -displayof . xyz
} -returnCodes error -result {expected boolean value but got "xyz"}
test tk-4.6 {tk command: useinputmethods: set new} -body {
# This isn't really a test, but more of a check... The answer is what was
# given, because we may be on a Unix system that doesn't have the XIM
# stuff
if {[tk useinputmethods 1] == 0} {
puts "this wish doesn't have XIM (X Input Methods) support"
}
return $useim
} -result $useim
test tk-4.7 {tk command: useinputmethods: set new} -constraints win -body {
# Mac and Windows don't have X Input Methods, so this should always return
# 0
tk useinputmethods 1
} -cleanup {
tk useinputmethods $useim
} -result 0
test tk-5.1 {tk caret} -body {
tk caret
} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}
test tk-5.2 {tk caret} -body {
tk caret bogus
} -returnCodes error -result {bad window path name "bogus"}
test tk-5.3 {tk caret} -body {
tk caret . -foo
} -returnCodes error -result {bad caret option "-foo": must be -x, -y, or -height}
test tk-5.4 {tk caret} -body {
tk caret . -x 0 -y
} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}
test tk-5.5 {tk caret} -body {
tk caret . -x 10 -y 11 -h 12; tk caret .
} -result {-height 12 -x 10 -y 11}
test tk-5.6 {tk caret} -body {
tk caret . -x 20 -y 25 -h 30; tk caret . -hei
} -result {30}
# tk inactive
test tk-6.1 {tk inactive} -body {
string is integer [tk inactive]
} -result 1
test tk-6.2 {tk inactive reset} -body {
tk inactive reset
} -returnCodes ok -match glob -result *
test tk-6.3 {tk inactive wrong argument} -body {
tk inactive foo
} -returnCodes 1 -result {bad option "foo": must be reset}
test tk-6.4 {tk inactive too many arguments} -body {
tk inactive reset foo
} -returnCodes 1 -result {wrong # args: should be "tk inactive ?-displayof window? ?reset?"}
test tk-6.5 {tk inactive} -body {
tk inactive reset
update
after 100
set i [tk inactive]
expr {$i == -1 || ( $i > 90 && $i < 200 )}
} -result 1
test tk-7.1 {tk inactive in a safe interpreter} -body {
# tk inactive in safe interpreters
safe::interpCreate foo
safe::loadTk foo
foo eval {tk inactive}
} -cleanup {
::safe::interpDelete foo
} -result -1
test tk-7.2 {tk inactive reset in a safe interpreter} -body {
# tk inactive in safe interpreters
safe::interpCreate foo
safe::loadTk foo
foo eval {tk inactive reset}
} -cleanup {
::safe::interpDelete foo
} -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter}
# tests of [tk busy] in busy.test
# cleanup
cleanupTests
return

20
tests/ttk/all.tcl Normal file
View File

@@ -0,0 +1,20 @@
# all.tcl --
#
# This file contains a top-level script to run all of the ttk
# tests. Execute it by invoking "source all.tcl" when running tktest
# in this directory.
#
# Copyright (c) 2007 by the Tk developers.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tk ;# This is the Tk test suite; fail early if no Tk!
package require tcltest 2.2
tcltest::configure {*}$argv
tcltest::configure -testdir [file normalize [file dirname [info script]]]
tcltest::configure -loadfile \
[file join [file dirname [tcltest::testsDirectory]] constraints.tcl]
tcltest::configure -singleproc 1
tcltest::runAllTests

64
tests/ttk/checkbutton.test Normal file
View File

@@ -0,0 +1,64 @@
#
# ttk::checkbutton widget tests.
#
package require Tk
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands
test checkbutton-1.1 "Checkbutton check" -body {
pack [ttk::checkbutton .cb -text "TCheckbutton" -variable cb]
}
test checkbutton-1.2 "Checkbutton invoke" -body {
.cb invoke
list [set ::cb] [.cb instate selected]
} -result [list 1 1]
test checkbutton-1.3 "Checkbutton reinvoke" -body {
.cb invoke
list [set ::cb] [.cb instate selected]
} -result [list 0 0]
test checkbutton-1.4 "Checkbutton variable" -body {
set result []
set ::cb 1
lappend result [.cb instate selected]
set ::cb 0
lappend result [.cb instate selected]
} -result {1 0}
test checkbutton-1.5 "Unset checkbutton variable" -body {
set result []
unset ::cb
lappend result [.cb instate alternate] [info exists ::cb]
set ::cb 1
lappend result [.cb instate alternate] [info exists ::cb]
} -result {1 0 0 1}
# See #1257319
test checkbutton-1.6 "Checkbutton default variable" -body {
destroy .cb ; unset -nocomplain {} ; set result [list]
ttk::checkbutton .cb -onvalue on -offvalue off
lappend result [.cb cget -variable] [info exists .cb] [.cb state]
.cb invoke
lappend result [info exists .cb] [set .cb] [.cb state]
.cb invoke
lappend result [info exists .cb] [set .cb] [.cb state]
} -result [list .cb 0 alternate 1 on selected 1 off {}]
# Bug [109865fa01]
test checkbutton-1.7 "Button destroyed by click" -body {
proc destroy_button {} {
destroy .top
}
toplevel .top
ttk::menubutton .top.mb -text Button -style TLabel
bind .top.mb <ButtonRelease-1> destroy_button
pack .top.mb
focus -force .top.mb
update
event generate .top.mb <1>
event generate .top.mb <ButtonRelease-1>
update ; # shall not trigger error invalid command name ".top.b"
} -result {}
tcltest::cleanupTests

68
tests/ttk/combobox.test Normal file
View File

@@ -0,0 +1,68 @@
#
# ttk::combobox widget tests
#
package require Tk 8.5
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands
test combobox-1.0 "Combobox tests -- setup" -body {
ttk::combobox .cb
} -result .cb
test combobox-1.1 "Bad -values list" -body {
.cb configure -values "bad \{list"
} -result "unmatched open brace in list" -returnCodes 1
test combobox-1.end "Combobox tests -- cleanup" -body {
destroy .cb
}
test combobox-2.0 "current command" -body {
ttk::combobox .cb -values [list a b c d e a]
.cb current
} -result -1
test combobox-2.1 "current -- set index" -body {
.cb current 5
.cb get
} -result a
test combobox-2.2 "current -- change -values" -body {
.cb configure -values [list c b a d e]
.cb current
} -result 2
test combobox-2.3 "current -- change value" -body {
.cb set "b"
.cb current
} -result 1
test combobox-2.4 "current -- value not in list" -body {
.cb set "z"
.cb current
} -result -1
test combobox-2.end "Cleanup" -body { destroy .cb }
test combobox-1890211 "ComboboxSelected event after listbox unposted" -body {
# whitebox test...
pack [ttk::combobox .cb -values [list a b c]]
set result [list]
bind .cb <<ComboboxSelected>> {
lappend result Event [winfo ismapped .cb.popdown] [.cb get]
}
lappend result Start 0 [.cb get]
ttk::combobox::Post .cb
lappend result Post [winfo ismapped .cb.popdown] [.cb get]
.cb.popdown.f.l selection clear 0 end; .cb.popdown.f.l selection set 1
ttk::combobox::LBSelected .cb.popdown.f.l
lappend result Select [winfo ismapped .cb.popdown] [.cb get]
update
set result
} -result [list Start 0 {} Post 1 {} Select 0 b Event 0 b] -cleanup {
destroy .cb
}
tcltest::cleanupTests

283
tests/ttk/entry.test Normal file
View File

@@ -0,0 +1,283 @@
#
# Tile package: entry widget tests
#
package require Tk 8.5
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands
variable scrollInfo
proc scroll args {
global scrollInfo
set scrollInfo $args
}
# Some of the tests raise background errors;
# override default bgerror to catch them.
#
variable bgerror ""
proc bgerror {error} {
variable bgerror $error
variable bgerrorInfo $::errorInfo
variable bgerrorCode $::errorCode
}
#
test entry-1.1 "Create entry widget" -body {
ttk::entry .e
} -result .e
test entry-1.2 "Insert" -body {
.e insert end abcde
.e get
} -result abcde
test entry-1.3 "Selection" -body {
.e selection range 1 3
selection get
} -result bc
test entry-1.4 "Delete" -body {
.e delete 1 3
.e get
} -result ade
test entry-1.5 "Deletion - insert cursor" -body {
.e insert end abcde
.e icursor 0
.e delete 0 end
.e index insert
} -result 0
test entry-1.6 "Deletion - insert cursor at end" -body {
.e insert end abcde
.e icursor end
.e delete 0 end
.e index insert
} -result 0
test entry-1.7 "Deletion - insert cursor in the middle " -body {
.e insert end abcde
.e icursor 3
.e delete 0 end
.e index insert
} -result 0
test entry-1.done "Cleanup" -body { destroy .e }
# Scrollbar tests.
test entry-2.1 "Create entry before scrollbar" -body {
pack [ttk::entry .te -xscrollcommand [list .tsb set]] \
-expand true -fill both
pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
-expand false -fill x
} -cleanup {destroy .te .tsb}
test entry-2.2 "Initial scroll position" -body {
ttk::entry .e -font fixed -width 5 -xscrollcommand scroll
.e insert end "0123456789"
pack .e; update
set scrollInfo
} -result {0.0 0.5} -cleanup { destroy .e }
# NOTE: result can vary depending on font.
# Bounding box / scrolling tests.
test entry-3.0 "Series 3 setup" -body {
ttk::style theme use default
variable fixed fixed
variable cw [font measure $fixed a]
variable ch [font metrics $fixed -linespace]
variable bd 2 ;# border + padding
variable ux [font measure $fixed \u4e4e]
pack [ttk::entry .e -font $fixed -width 20]
update
}
test entry-3.1 "bbox widget command" -body {
.e delete 0 end
.e bbox 0
} -result [list $bd $bd 0 $ch]
test entry-3.2 "xview" -body {
.e delete 0 end;
.e insert end [string repeat "0" 40]
update idletasks
set result [.e xview]
} -result {0.0 0.5}
test entry-3.last "Series 3 cleanup" -body {
destroy .e
}
# Selection tests:
test entry-4.0 "Selection test - setup" -body {
ttk::entry .e
.e insert end asdfasdf
.e selection range 0 end
}
test entry-4.1 "Selection test" -body {
selection get
} -result asdfasdf
test entry-4.2 "Disable -exportselection" -body {
.e configure -exportselection false
selection get
} -returnCodes error -result "PRIMARY selection doesn't exist*" -match glob
test entry-4.3 "Reenable -exportselection" -body {
.e configure -exportselection true
selection get
} -result asdfasdf
test entry-4.4 "Force selection loss" -body {
selection own .
.e index sel.first
} -returnCodes error -result "selection isn't in widget .e"
test entry-4.5 "Allow selection changes if readonly" -body {
.e delete 0 end
.e insert end 0123456789
.e selection range 0 end
.e configure -state readonly
.e selection range 2 4
.e configure -state normal
list [.e index sel.first] [.e index sel.last]
} -result {2 4}
test entry-4.6 "Disallow selection changes if disabled" -body {
.e delete 0 end
.e insert end 0123456789
.e selection range 0 end
.e configure -state disabled
.e selection range 2 4
.e configure -state normal
list [.e index sel.first] [.e index sel.last]
} -result {0 10}
test entry-4.7 {sel.first and sel.last gravity} -body {
set result [list]
.e delete 0 end
.e insert 0 0123456789
.e select range 2 6
.e insert 2 XXX
lappend result [.e index sel.first] [.e index sel.last]
.e insert 6 YYY
lappend result [.e index sel.first] [.e index sel.last] [.e get]
} -result {5 9 5 12 01XXX2YYY3456789}
# Self-destruct tests.
test entry-5.1 {widget deletion while active} -body {
destroy .e
pack [ttk::entry .e]
update
.e config -xscrollcommand { destroy .e }
update idletasks
winfo exists .e
} -result 0
# TODO: test killing .e in -validatecommand, -invalidcommand, variable trace;
# -textvariable tests.
test entry-6.1 {Update linked variable in write trace} -body {
proc override args {
global x
set x "Overridden!"
}
catch {destroy .e}
set x ""
trace variable x w override
ttk::entry .e -textvariable x
.e insert 0 "Some text"
set result [list $x [.e get]]
set result
} -result {Overridden! Overridden!} -cleanup {
unset x
rename override {}
destroy .e
}
test entry-6.2 {-textvariable tests} -body {
set result [list]
ttk::entry .e -textvariable x
set x "text"
lappend result [.e get]
unset x
lappend result [.e get]
.e insert end "newtext"
lappend result [.e get] [set x]
} -result [list "text" "" "newtext" "newtext"] -cleanup {
destroy .e
unset -nocomplain x
}
test entry-7.1 {Bad style options} -body {
ttk::style theme create entry-7.1 -settings {
ttk::style configure TEntry -foreground BadColor
ttk::style map TEntry -foreground {readonly AnotherBadColor}
ttk::style map TEntry -font {readonly ABadFont}
ttk::style map TEntry \
-selectbackground {{} BadColor} \
-selectforeground {{} BadColor} \
-insertcolor {{} BadColor}
}
pack [ttk::entry .e -text "Don't crash"]
ttk::style theme use entry-7.1
update
.e selection range 0 end
update
.e state readonly;
update
} -cleanup { destroy .e ; ttk::style theme use default }
test entry-8.1 "Unset linked variable" -body {
variable foo "bar"
pack [ttk::entry .e -textvariable foo]
unset foo
.e insert end "baz"
list [.e cget -textvariable] [.e get] [set foo]
} -result [list foo "baz" "baz"] -cleanup { destroy .e }
test entry-8.2 "Unset linked variable by deleting namespace" -body {
namespace eval ::test { variable foo "bar" }
pack [ttk::entry .e -textvariable ::test::foo]
namespace delete ::test
.e insert end "baz" ;# <== error here
list [.e cget -textvariable] [.e get] [set foo]
} -returnCodes error -result "*parent namespace doesn't exist*" -match glob
# '-result [list ::test::foo "baz" "baz"]' would also be sensible,
# but Tcl namespaces don't work that way.
test entry-8.2a "Followup to test 8.2" -body {
.e cget -textvariable
} -result ::test::foo -cleanup { destroy .e }
# For 8.2a, -result {} would also be sensible.
test entry-9.1 "Index range invariants" -setup {
# See bug#1721532 for discussion
proc entry-9.1-trace {n1 n2 op} {
set ::V NO!
}
variable V
trace add variable V write entry-9.1-trace
ttk::entry .e -textvariable V
} -body {
set result [list]
.e insert insert a ; lappend result [.e index insert] [.e index end]
.e insert insert b ; lappend result [.e index insert] [.e index end]
.e insert insert c ; lappend result [.e index insert] [.e index end]
.e insert insert d ; lappend result [.e index insert] [.e index end]
.e insert insert e ; lappend result [.e index insert] [.e index end]
set result
} -result [list 1 3 2 3 3 3 3 3 3 3] -cleanup {
unset V
destroy .e
}
tcltest::cleanupTests

50
tests/ttk/image.test Normal file
View File

@@ -0,0 +1,50 @@
package require Tk 8.5
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands
test image-1.1 "Bad image element" -body {
ttk::style element create BadImage image badimage
} -returnCodes error -result {image "badimage" doesn't exist}
test image-1.2 "Duplicate element" -setup {
image create photo test.element -width 10 -height 10
ttk::style element create testElement image test.element
} -body {
ttk::style element create testElement image test.element
} -returnCodes 1 -result "Duplicate element testElement"
test image-2.0 "Deletion of displayed image (label)" -setup {
image create photo test.image -width 10 -height 10
} -body {
pack [set w [ttk::label .ttk_image20 -image test.image]]
tkwait visibility $w
image delete test.image
update
} -cleanup {
destroy .ttk_image20
} -result {}
test image-2.1 "Deletion of displayed image (checkbutton)" -setup {
image create photo test.image -width 10 -height 10
} -body {
pack [set w [ttk::checkbutton .ttk_image21 -image test.image]]
tkwait visibility $w
image delete test.image
update
} -cleanup {
destroy .ttk_image21
} -result {}
test image-2.2 "Deletion of displayed image (radiobutton)" -setup {
image create photo test.image -width 10 -height 10
} -body {
pack [set w [ttk::radiobutton .ttk_image22 -image test.image]]
tkwait visibility $w
image delete test.image
update
} -cleanup {
destroy .ttk_image22
} -result {}
#
tcltest::cleanupTests

130
tests/ttk/labelframe.test Normal file
View File

@@ -0,0 +1,130 @@
package require Tk 8.5
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands
test labelframe-1.0 "Setup" -body {
pack [ttk::labelframe .lf] -expand true -fill both
}
test labelframe-2.1 "Can't use indirect descendant as labelwidget" -body {
ttk::frame .lf.t
ttk::checkbutton .lf.t.cb
.lf configure -labelwidget .lf.t.cb
} -returnCodes 1 -result "can't *" -match glob \
-cleanup { destroy .lf.t } ;
test labelframe-2.2 "Can't use toplevel as labelwidget" -body {
toplevel .lf.t
.lf configure -labelwidget .lf.t
} -returnCodes 1 -result "can't *" -match glob \
-cleanup { destroy .lf.t } ;
test labelframe-2.3 "Can't use non-windows as -labelwidget" -body {
.lf configure -labelwidget BogusWindowName
} -returnCodes 1 -result {bad window path name "BogusWindowName"}
test labelframe-2.4 "Can't use nonexistent-windows as -labelwidget" -body {
.lf configure -labelwidget .nosuchwindow
} -returnCodes 1 -result {bad window path name ".nosuchwindow"}
###
# See also series labelframe-4.x
#
test labelframe-3.1 "Add child slave" -body {
checkbutton .lf.cb -text "abcde"
.lf configure -labelwidget .lf.cb
list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
} -result [list 1 labelframe]
test labelframe-3.2 "Remove child slave" -body {
.lf configure -labelwidget {}
list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
} -result [list 0 {}]
test labelframe-3.3 "Re-add child slave" -body {
.lf configure -labelwidget .lf.cb
list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
} -result [list 1 labelframe]
test labelframe-3.4 "Re-manage child slave" -body {
pack .lf.cb -side right
list [update; winfo viewable .lf.cb] [winfo manager .lf.cb] [.lf cget -labelwidget]
} -result [list 1 pack {}]
test labelframe-3.5 "Re-add child slave" -body {
.lf configure -labelwidget .lf.cb
list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
} -result [list 1 labelframe]
test labelframe-3.6 "Destroy child slave" -body {
destroy .lf.cb
.lf cget -labelwidget
} -result {}
###
# Re-run series labelframe-3.x with nonchild slaves.
#
# @@@ ODDITY, 14 Nov 2005:
# @@@ labelframe-4.1 fails if .cb is a [checkbutton],
# @@@ but seems to succeed if it's some other widget class.
# @@@ I suspect a race condition; unable to track it down ATM.
#
# @@@ FOLLOWUP: This *may* have been caused by a bug in ManagerIdleProc
# @@@ (see manager.c r1.11). There's still probably a race condition in here.
#
test labelframe-4.1 "Add nonchild slave" -body {
checkbutton .cb -text "abcde"
.lf configure -labelwidget .cb
update
list [winfo ismapped .cb] [winfo viewable .cb] [winfo manager .cb]
} -result [list 1 1 labelframe]
test labelframe-4.2 "Remove nonchild slave" -body {
.lf configure -labelwidget {}
update;
list [winfo ismapped .cb] [winfo viewable .cb] [winfo manager .cb]
} -result [list 0 0 {}]
test labelframe-4.3 "Re-add nonchild slave" -body {
.lf configure -labelwidget .cb
list [update; winfo viewable .cb] [winfo manager .cb]
} -result [list 1 labelframe]
test labelframe-4.4 "Re-manage nonchild slave" -body {
pack .cb -side right
list [update; winfo viewable .cb] \
[winfo manager .cb] \
[.lf cget -labelwidget]
} -result [list 1 pack {}]
test labelframe-4.5 "Re-add nonchild slave" -body {
.lf configure -labelwidget .cb
list [update; winfo viewable .cb] \
[winfo manager .cb] \
[.lf cget -labelwidget]
} -result [list 1 labelframe .cb]
test labelframe-4.6 "Destroy nonchild slave" -body {
destroy .cb
.lf cget -labelwidget
} -result {}
test labelframe-5.0 "Cleanup" -body {
destroy .lf
}
# 1342876 -- labelframe should raise sibling -labelwidget above self.
#
test labelframe-6.1 "Stacking order" -body {
toplevel .t
pack [ttk::checkbutton .t.x1]
pack [ttk::labelframe .t.lf -labelwidget [ttk::label .t.lb]]
pack [ttk::checkbutton .t.x2]
winfo children .t
} -cleanup {
destroy .t
} -result [list .t.x1 .t.lf .t.lb .t.x2]
tcltest::cleanupTests

Some files were not shown because too many files have changed in this diff Show More