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

Imported Tk 8.6.9

Browse Source
This commit is contained in:
Steve Dower
2018-12-11 10:05:28 -08:00
parent 753ac6b037
commit 5ba5cbc9af
184 changed files with 6223 additions and 1994 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
tests/bind.test
View File

@@ -39,10 +39,10 @@ proc unsetBindings {} {
# events to make sure that there are no stray events in the ring
# buffer which might cause the pattern matcher to find unintended
# matches. The size of the ring buffer is EVENT_BUFFER_SIZE, which is
# currently set to 30. If this changes, the code below will need to
# change.
# currently set to 30 (or 45 on macOS). If this changes, the code
# below will need to change.
proc clearRingBuffer {{event}} {
for {set i 0} {$i < 30} {incr i} {
for {set i 0} {$i < 45} {incr i} {
event generate . $event
}
}

9
tests/bitmap.test
View File

@@ -84,12 +84,14 @@ test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} -constraints {
test bitmap-4.1 {FreeBitmapObjProc} -constraints {
testbitmap
} -setup {
proc copy {s} {return [string index $s 0][string range $s 1 end]}
} -body {
set x [join questhead]
set x [copy questhead]
button .b -bitmap $x
set y [join questhead]
set y [copy questhead]
.b configure -bitmap $y
set z [join questhead]
set z [copy questhead]
.b configure -bitmap $z
set result {}
lappend result [testbitmap questhead]
@@ -102,6 +104,7 @@ test bitmap-4.1 {FreeBitmapObjProc} -constraints {
set y bogus
return $result
} -cleanup {
rename copy {}
destroy .b
} -result {{{1 3}} {{1 2}} {{1 1}} {}}

8
tests/border.test
View File

@@ -131,12 +131,13 @@ test border-3.1 {FreeBorderObjProc} -constraints {
testborder
} -setup {
set result {}
proc copy {s} {return [string index $s 0][string range $s 1 end]}
} -body {
set x [join purple]
set x [copy purple]
button .b -bg $x -text .b1
set y [join purple]
set y [copy purple]
.b configure -bg $y
set z [join purple]
set z [copy purple]
.b configure -bg $z
lappend result [testborder purple]
set x red
@@ -148,6 +149,7 @@ test border-3.1 {FreeBorderObjProc} -constraints {
set y bogus
return $result
} -cleanup {
rename copy {}
destroy .b
} -result {{{1 3}} {{1 2}} {{1 1}} {}}

8
tests/canvImg.test
View File

@@ -173,7 +173,7 @@ test canvImg-4.2 {ConfiugreImage procedure} -constraints testImageType -setup {
.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}}
} -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60}} {50 100 130 160}}
test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup {
.c delete all
} -body {
@@ -733,7 +733,7 @@ test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup {
} -cleanup {
.c delete all
image delete foo
} -result {{foo display 2 4 6 8 30 30}}
} -result {{foo display 2 4 6 8}}
test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup {
.c delete all
@@ -748,7 +748,7 @@ test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup {
} -cleanup {
.c delete all
image delete foo
} -result {{foo display 0 0 40 50 30 30}}
} -result {{foo display 0 0 40 50}}
test canvImg-11.2 {ImageChangedProc procedure} -constraints {
testImageType
} -setup {
@@ -784,7 +784,7 @@ test canvImg-11.3 {ImageChangedProc procedure} -constraints {
} -cleanup {
.c delete all
image delete foo foo2
} -result {{foo2 display 0 0 20 40 50 40}}
} -result {{foo2 display 0 0 20 40}}
# cleanup
imageFinish

4
tests/canvText.test
View File

@@ -55,8 +55,8 @@ test canvText-1.10 {configuration options: good value for "stipple"} -body {
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}
.c itemconfigure test -stipple abcxyz
} -returnCodes error -result {bitmap "abcxyz" 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]

16
tests/choosedir.test
View File

@@ -85,23 +85,25 @@ set fake [file join $dir non-existant]
set parent .
test choosedir-1.1 {tk_chooseDirectory command} -constraints unix -body {
test choosedir-1.1 {tk_chooseDirectory command} -body {
tk_chooseDirectory -initialdir
} -returnCodes error -result {value for "-initialdir" missing}
test choosedir-1.2 {tk_chooseDirectory command} -constraints unix -body {
test choosedir-1.2 {tk_chooseDirectory command} -body {
tk_chooseDirectory -mustexist
} -returnCodes error -result {value for "-mustexist" missing}
test choosedir-1.3 {tk_chooseDirectory command} -constraints unix -body {
test choosedir-1.3 {tk_chooseDirectory command} -body {
tk_chooseDirectory -parent
} -returnCodes error -result {value for "-parent" missing}
test choosedir-1.4 {tk_chooseDirectory command} -constraints unix -body {
test choosedir-1.4 {tk_chooseDirectory command} -body {
tk_chooseDirectory -title
} -returnCodes error -result {value for "-title" missing}
test choosedir-1.5 {tk_chooseDirectory command} -constraints unix -body {
test choosedir-1.5.1 {tk_chooseDirectory command} -constraints notAqua -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 {
test choosedir-1.5.2 {tk_chooseDirectory command} -constraints aqua -body {
tk_chooseDirectory -foo bar
} -returnCodes error -result {bad option "-foo": must be -initialdir, -message, -mustexist, -parent, -title, or -command}
test choosedir-1.6 {tk_chooseDirectory command} -body {
tk_chooseDirectory -parent foo.bar
} -returnCodes error -result {bad window path name "foo.bar"}

8
tests/clipboard.test
View File

@@ -161,8 +161,7 @@ test clipboard-4.3 {ClipboardLostSel procedure} -setup {
clipboard append "Test"
clipboard append -t TEST "Test2"
selection clear -s CLIPBOARD
catch {clipboard get}
clipboard get -t TEST
clipboard get -t TEST
} -cleanup {
clipboard clear
} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined}
@@ -184,8 +183,7 @@ test clipboard-4.5 {ClipboardLostSel procedure} -setup {
clipboard append -t TEST "Test2"
clipboard append "Test3"
selection clear -s CLIPBOARD
catch {clipboard get}
clipboard get -t TEST
clipboard get -t TEST
} -cleanup {
clipboard clear
} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined}
@@ -230,7 +228,7 @@ test clipboard-6.1 {Tk_ClipboardAppend procedure} -setup {
} -cleanup {
clipboard clear
} -returnCodes ok -result {first chunk second chunk}
test clipboard-6.2 {Tk_ClipboardAppend procedure} -constraints unix -setup {
test clipboard-6.2 {Tk_ClipboardAppend procedure} -constraints x11 -setup {
clipboard clear
} -body {
setupbg

16
tests/color.test
View File

@@ -277,13 +277,17 @@ test color-3.4 {Tk_FreeColorFromObj - unlinking from list} colorsFree {
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 {
test color-4.1 {FreeColorObjProc} -constraints {
colorsFree
} -setup {
proc copy {s} {return [string index $s 0][string range $s 1 end]}
} -body {
destroy .b
set x [format purple]
set x [copy purple]
button .b -foreground $x -text .b1
set y [format purple]
set y [copy purple]
.b configure -foreground $y
set z [format purple]
set z [copy purple]
.b configure -foreground $z
set result {}
lappend result [testcolor purple]
@@ -295,7 +299,9 @@ test color-4.1 {FreeColorObjProc} colorsFree {
lappend result [testcolor purple]
set y bogus
set result
} {{{1 3}} {{1 2}} {{1 1}} {}}
} -cleanup {
rename copy {}
} -result {{{1 3}} {{1 2}} {{1 1}} {}}
destroy .t

4
tests/config.test
View File

@@ -679,10 +679,10 @@ test config-4.56 {DoObjConfig - new bitmap} -constraints testobjconfig -body {
test config-4.57 {DoObjConfig - invalid bitmap} -constraints {
testobjconfig
} -body {
testobjconfig alltypes .foo -bitmap foo
testobjconfig alltypes .foo -bitmap foobar
} -cleanup {
killTables
} -returnCodes error -result {bitmap "foo" not defined}
} -returnCodes error -result {bitmap "foobar" not defined}
test config-4.58 {DoObjConfig - null bitmap} -constraints testobjconfig -body {
testobjconfig alltypes .foo -bitmap {}
} -cleanup {

BIN
tests/corruptMangled.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 64 B

2
tests/corruptMangled4G.gif Normal file
View File

@@ -0,0 +1,2 @@
GIF89a<EFBFBD>f3<EFBFBD><EFBFBD>33<EFBFBD>3<EFBFBD>3<EFBFBD>33<EFBFBD><EFBFBD><EFBFBD><EFBFBD>3<EFBFBD><EFBFBD><EFBFBD>!<21>
,!x<><78>-0Bw<42><77>ڥ<EFBFBD><DAA5><EFBFBD>J<EFBFBD>8U<38><55>kir/3Re7 ;
Side by Side

After

Width:  |  Height:  |  Size: 64 B

BIN
tests/corruptTruncated.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 32 B

9
tests/cursor.test
View File

@@ -144,12 +144,14 @@ test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} -constraints {
test cursor-4.1 {FreeCursorObjProc} -constraints {
testcursor
} -setup {
proc copy {s} {return [string index $s 0][string range $s 1 end]}
} -body {
set x [join heart]
set x [copy heart]
button .b -cursor $x
set y [join heart]
set y [copy heart]
.b configure -cursor $y
set z [join heart]
set z [copy heart]
.b configure -cursor $z
set result {}
lappend result [testcursor heart]
@@ -162,6 +164,7 @@ test cursor-4.1 {FreeCursorObjProc} -constraints {
set y bogus
set result
} -cleanup {
rename copy {}
destroy .b
} -result {{{1 3}} {{1 2}} {{1 1}} {}}

BIN
tests/deferredClearCode.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 23 KiB

34
tests/filebox.test
View File

@@ -110,8 +110,10 @@ if {$tcl_platform(platform) == "unix"} {
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 unknownOptionsMsg(tk_getOpenFile,notAqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
set unknownOptionsMsg(tk_getOpenFile,aqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -message, -multiple, -parent, -title, -typevariable, or -command}
set unknownOptionsMsg(tk_getSaveFile,notAqua) {bad option "-foo": must be -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable}
set unknownOptionsMsg(tk_getSaveFile,aqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -message, -parent, -title, -typevariable, -command, or -confirmoverwrite}
set tmpFile "filebox.tmp"
makeFile {
@@ -155,9 +157,12 @@ foreach mode $modes {
}
}
test filebox-1.1-$mode "tk_getOpenFile command" -body {
test filebox-1.1.1-$mode "tk_getOpenFile command" -constraints notAqua -body {
tk_getOpenFile -foo
} -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
} -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,notAqua)
test filebox-1.1.2-$mode "tk_getOpenFile command" -constraints aqua -body {
tk_getOpenFile -foo
} -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,aqua)
catch {tk_getOpenFile -foo 1} msg
regsub -all , $msg "" options
@@ -171,9 +176,12 @@ foreach mode $modes {
}
}
test filebox-1.3-$mode "tk_getOpenFile command" -body {
test filebox-1.3.1-$mode "tk_getOpenFile command" -constraints notAqua -body {
tk_getOpenFile -foo bar
} -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
} -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,notAqua)
test filebox-1.3.2-$mode "tk_getOpenFile command" -constraints aqua -body {
tk_getOpenFile -foo bar
} -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,aqua)
test filebox-1.4-$mode "tk_getOpenFile command" -body {
tk_getOpenFile -initialdir
} -returnCodes error -result {value for "-initialdir" missing}
@@ -289,9 +297,12 @@ foreach mode $modes {
} $res
}
test filebox-4.1-$mode "tk_getSaveFile command" -body {
test filebox-4.1.1-$mode "tk_getSaveFile command" -constraints notAqua -body {
tk_getSaveFile -foo
} -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
} -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,notAqua)
test filebox-4.1.2-$mode "tk_getSaveFile command" -constraints aqua -body {
tk_getSaveFile -foo
} -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,aqua)
catch {tk_getSaveFile -foo 1} msg
regsub -all , $msg "" options
@@ -305,9 +316,12 @@ foreach mode $modes {
}
}
test filebox-4.3-$mode "tk_getSaveFile command" -body {
test filebox-4.3.1-$mode "tk_getSaveFile command" -constraints notAqua -body {
tk_getSaveFile -foo bar
} -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
} -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,notAqua)
test filebox-4.3.2-$mode "tk_getSaveFile command" -constraints aqua -body {
tk_getSaveFile -foo bar
} -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,aqua)
test filebox-4.4-$mode "tk_getSaveFile command" -body {
tk_getSaveFile -initialdir
} -returnCodes error -result {value for "-initialdir" missing}

17
tests/font.test
View File

@@ -38,7 +38,7 @@ wm geom .t +0+0
update idletasks
switch [tk windowingsystem] {
x11 {set fixed "fixed"}
x11 {set fixed "TkFixedFont"}
win32 {set fixed "courier 12"}
aqua {set fixed "monaco 9"}
}
@@ -921,7 +921,7 @@ test font-21.5 {Tk_PostscriptFontName procedure: spaces} -constraints {
}
} -result {LucidaBright}
test font-21.6 {Tk_PostscriptFontName procedure: spaces} -constraints {
unix
x11
} -body {
psfontname "{new century schoolbook} 10"
} -result {NewCenturySchlbk-Roman}
@@ -2356,10 +2356,15 @@ test font-45.1 {TkFontGetAliasList: no match} -body {
test font-45.2 {TkFontGetAliasList: match} -constraints win -body {
font actual {times 10} -family
} -result {Times New Roman}
test font-45.3 {TkFontGetAliasList: match} -constraints {unix noExceed} -body {
# can fail on Unix systems that have a real "times new roman" font
font actual {{times new roman} 10} -family
} -result [font actual {times 10} -family]
test font-45.3 {TkFontGetAliasList: match} -constraints {noExceed} -body {
if {[font actual {{times new roman} 10} -family] eq "Times New Roman"} {
# avoid test failure on systems that have a real "times new roman" font
set res 1
} else {
set res [expr {[font actual {{times new roman} 10} -family] eq \
[font actual {times 10} -family]} ]
}
} -result {1}
test font-46.1 {font actual, with character, no option, no --} -body {

BIN
tests/iDOT.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 6.1 KiB

10
tests/image.test
View File

@@ -67,7 +67,7 @@ test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints {
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}}
} -result {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15} {myimage display 0 0 30 15}}
test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints {
testImageType
} -setup {
@@ -86,7 +86,7 @@ test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints {
} -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}}
} -result {{myimage get} {myimage get} {myimage display 0 0 30 15} {myimage display 0 0 30 15}}
test image-1.9 {Tk_ImageCmd procedure, "create" option} -constraints {
testImageType
} -body {
@@ -360,7 +360,7 @@ test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup {
} -cleanup {
.c delete all
imageCleanup
} -result {{foo display 5 6 7 8 30 30}}
} -result {{foo display 5 6 7 8}}
test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup {
.c delete all
imageCleanup
@@ -376,7 +376,7 @@ test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup {
} -cleanup {
.c delete all
imageCleanup
} -result {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}}
} -result {{foo display 5 6 25 9} {foo display 0 0 12 14}}
test image-10.1 {Tk_GetImage procedure} -setup {
@@ -417,7 +417,7 @@ test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup {
} -cleanup {
.c delete all
imageCleanup
} -result {foo {{foo free} {foo display 0 0 30 15 103 121}}}
} -result {foo {{foo free} {foo display 0 0 30 15}}}
test image-11.2 {Tk_FreeImage procedure} -constraints testImageType -setup {
.c delete all
imageCleanup

10
tests/imgPhoto.test
View File

@@ -1201,6 +1201,16 @@ test imgPhoto-14.4 {GIF buffer overflow} -setup {
} -cleanup {
image delete $i
} -returnCodes error -result {malformed image}
test imgPhoto-14.5 {Bug [fbaed1f66b] - GIF decoder with deferred clear code} -setup {
set fileName [file join [file dirname [info script]] deferredClearCode.gif]
} -body {
# This erroneously produced "malformed image" error.
# The animated GIF "deferredClearCode.gif" has two frames, and calling for -index 2
# simply is an easy way to trigger the problem of improper management of a deferred
# clear code. The effect was that the GIF decoder bailed out before the end of the
# image reading, and produced the inappropriate "malformed image error".
image create photo -file $fileName -format "gif -index 2"
} -returnCodes error -result {no image data for this index}
test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} -constraints {
nonPortable

26
tests/msgbox.test
View File

@@ -11,12 +11,18 @@ tcltest::loadTestedCommands
namespace import -force tcltest::test
test msgbox-1.1 {tk_messageBox command} -body {
test msgbox-1.1.1 {tk_messageBox command} -constraints notAqua -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 {
test msgbox-1.1.2 {tk_messageBox command} -constraints aqua -body {
tk_messageBox -foo
} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, -type, or -command}
test msgbox-1.2.1 {tk_messageBox command} -constraints notAqua -body {
tk_messageBox -foo bar
} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
test msgbox-1.2.2 {tk_messageBox command} -constraints aqua -body {
tk_messageBox -foo bar
} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, -type, or -command}
test msgbox-1.3 {tk_messageBox command} -body {
tk_messageBox -default
@@ -48,30 +54,22 @@ 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 {
test msgbox-1.13 {tk_messageBox command} -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 {
test msgbox-1.14 {tk_messageBox command} -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 {
test msgbox-1.16 {tk_messageBox command} -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"}

18
tests/option.test
View File

@@ -386,7 +386,7 @@ test option-15.6 {database files} -body {
test option-15.7 {database files} -body {
option read $option1
option get . x9 color
} -result " \t\\A\n"
} -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?"}
@@ -415,6 +415,22 @@ test option-16.1 {ReadOptionFile} -body {
removeFile $option4
} -result {true false}
set opt162val {label {
foo bar
}
}
set opt162list [split $opt162val \n]
test option-16.2 {ticket 766ef52f3} {
set option5 [makeFile {} option.file4]
set file [open $option5 w]
fconfigure $file -translation crlf
puts $file "*notok: $opt162list"
close $file
option read $option5 userDefault
option get . notok notok
} $opt162list
deleteWindows
# cleanup

30
tests/packgrid.test
View File

@@ -246,5 +246,35 @@ test packgrid-3.4 {stealing slave} -setup {
destroy .g
} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
test packgrid-4.1 {slave stolen after master destruction - bug [aa7679685e]} -setup {
frame .f
button .b -text hello
} -body {
pack .f
grid .b -in .f
destroy .f
set res [winfo manager .b]
# shall not crash
pack .b
set res
} -cleanup {
destroy .b
} -result {}
test packgrid-4.2 {slave stolen after master destruction - bug [aa7679685e]} -setup {
frame .f
button .b -text hello
} -body {
pack .f
pack .b -in .f
destroy .f
set res [winfo manager .b]
# shall not crash
grid .b
set res
} -cleanup {
destroy .b
} -result {}
cleanupTests
return

BIN
tests/red.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 92 B

1220
tests/safePrimarySelection.test Normal file
View File

File diff suppressed because it is too large Load Diff

143
tests/scrollbar.test
View File

@@ -18,23 +18,38 @@ proc scroll args {
proc getTroughSize {w} {
if {[testConstraint testmetrics]} {
# Only Windows has [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]
}
if {[tk windowingsystem] eq "x11"} {
# Calculations here assume that the arrow area is a square.
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]
}
} else {
# macOS aqua
if [string match v* [$w cget -orient]] {
return [expr [winfo height $w] \
- ([$w cget -highlightthickness] \
+[$w cget -bd])*2]
} else {
return [expr [winfo width $w] \
- ([$w cget -highlightthickness] \
+[$w cget -bd])*2]
}
}
}
}
@@ -255,13 +270,13 @@ 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 {
test scrollbar-3.36 {ScrollbarWidgetCmd procedure, "fraction" option} x11 {
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 {
test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} x11 {
format {%.6g} [.s fraction 4 178]
} {0.993711}
test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics win} {
@@ -281,9 +296,15 @@ test scrollbar-3.41 {ScrollbarWidgetCmd procedure, "fraction" option} {
format {%.6g} [.t.s fraction 100 0]
} {0.5}
if {[testConstraint testmetrics]} {
# Only Windows has [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]
if {[tk windowingsystem] eq "x11"} {
place configure .t.s -width [expr [winfo height .t.s] - 2*([.t.s cget -highlightthickness] + [.t.s cget -bd] + 1)]
} else {
# macOS aqua
place configure .t.s -width [expr 2*([.t.s cget -highlightthickness] + [.t.s cget -bd])]
}
}
update
test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} {
@@ -317,9 +338,13 @@ test scrollbar-3.48 {ScrollbarWidgetCmd procedure, "identify" option} {
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} {
test scrollbar-3.50.1 {ScrollbarWidgetCmd procedure, "identify" option} notAqua {
.s identify 5 5
} {arrow1}
test scrollbar-3.50.1 {ScrollbarWidgetCmd procedure, "identify" option} aqua {
# macOS scrollbars have no arrows nowadays
.s identify 5 5
} {trough1}
test scrollbar-3.51 {ScrollbarWidgetCmd procedure, "identify" option} {
.s identify 5 35
} {trough1}
@@ -330,9 +355,13 @@ test scrollbar-3.52 {ScrollbarWidgetCmd procedure, "identify" option} {
test scrollbar-3.53 {ScrollbarWidgetCmd procedure, "identify" option} {
.s identify 5 145
} {trough2}
test scrollbar-3.54 {ScrollbarWidgetCmd procedure, "identify" option} {unixOrPc} {
test scrollbar-3.54.1 {ScrollbarWidgetCmd procedure, "identify" option} notAqua {
.s identify 5 195
} {arrow2}
test scrollbar-3.54.2 {ScrollbarWidgetCmd procedure, "identify" option} aqua {
# macOS scrollbars have no arrows nowadays
.s identify 5 195
} {trough2}
test scrollbar-3.56 {ScrollbarWidgetCmd procedure, "identify" option} unix {
.s identify 0 0
} {}
@@ -455,12 +484,20 @@ test scrollbar-6.9 {ScrollbarPosition procedure} {
test scrollbar-6.10 {ScrollbarPosition procedure} {
.s identify [winfo width .s] [expr [winfo height .s] / 2]
} {}
test scrollbar-6.11 {ScrollbarPosition procedure} unix {
test scrollbar-6.11.1 {ScrollbarPosition procedure} x11 {
.s identify 8 4
} {arrow1}
test scrollbar-6.12 {ScrollbarPosition procedure} unix {
test scrollbar-6.11.2 {ScrollbarPosition procedure} aqua {
# macOS scrollbars have no arrows nowadays
.s identify 8 4
} {trough1}
test scrollbar-6.12.1 {ScrollbarPosition procedure} x11 {
.s identify 8 19
} {arrow1}
test scrollbar-6.12.2 {ScrollbarPosition procedure} aqua {
# macOS scrollbars have no arrows nowadays
.s identify 8 19
} {trough1}
test scrollbar-6.14 {ScrollbarPosition procedure} win {
.s identify [expr [winfo width .s] / 2] 0
} {arrow1}
@@ -504,11 +541,7 @@ test scrollbar-6.24 {ScrollbarPosition procedure} unix {
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
test scrollbar-6.27 {ScrollbarPosition procedure} {testmetrics win} {
.s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \
+ [testmetrics cyvscroll .s]]
} {trough2}
@@ -516,12 +549,20 @@ 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 {
test scrollbar-6.29.1 {ScrollbarPosition procedure} x11 {
.s identify 8 180
} {arrow2}
test scrollbar-6.30 {ScrollbarPosition procedure} unix {
test scrollbar-6.29.2 {ScrollbarPosition procedure} aqua {
# macOS scrollbars have no arrows nowadays
.s identify 8 180
} {trough2}
test scrollbar-6.30.1 {ScrollbarPosition procedure} x11 {
.s identify 8 195
} {arrow2}
test scrollbar-6.30.2 {ScrollbarPosition procedure} aqua {
# macOS scrollbars have no arrows nowadays
.s identify 8 195
} {trough2}
test scrollbar-6.32 {ScrollbarPosition procedure} {testmetrics win} {
.s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \
- [testmetrics cyvscroll .s]]
@@ -550,15 +591,23 @@ place .t.s -width 200
.t.s set .2 .4
update
test scrollbar-6.39 {ScrollbarPosition procedure} unix {
test scrollbar-6.39.1 {ScrollbarPosition procedure} x11 {
.t.s identify 4 8
} {arrow1}
test scrollbar-6.39.2 {ScrollbarPosition procedure} aqua {
# macOS scrollbars have no arrows nowadays
.t.s identify 4 8
} {trough1}
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 {
test scrollbar-6.41.1 {ScrollbarPosition procedure} x11 {
.t.s identify 82 8
} {slider}
test scrollbar-6.41.2 {ScrollbarPosition procedure} aqua {
# macOS scrollbars have no arrows nowadays
.t.s identify 82 8
} {trough2}
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]
@@ -582,7 +631,9 @@ test scrollbar-7.1 {EventuallyRedraw} {
catch {destroy .t}
toplevel .t
wm geometry .t +0+0
test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} {
test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} notAqua {
# constrained by notAqua because this test clicks on an arrow of the
# scrollbar - but macOS has no such arrows in modern scrollbars
proc doit {args} { destroy .t.f }
proc bgerror {args} {}
destroy .t.f
@@ -601,7 +652,9 @@ test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} {
rename bgerror {}
set result
} {1 0 0}
test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} {
test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} notAqua {
# constrained by notAqua because this test clicks on an arrow of the
# scrollbar - but macOS has no such arrows in modern scrollbars
proc doit {args} { destroy .t.f.s }
proc bgerror {args} {}
destroy .t.f
@@ -632,7 +685,7 @@ test scrollbar-9.1 {scrollbar widget vs hidden commands} {
list [winfo children .] [interp hidden]
} [list {} $l]
test scrollbar-10.1 {<MouseWheel> event on scrollbar} -constraints {win|unix} -setup {
test scrollbar-10.1.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} -setup {
destroy .t .s
} -body {
pack [text .t -yscrollcommand {.s set}] -side left
@@ -646,8 +699,22 @@ test scrollbar-10.1 {<MouseWheel> event on scrollbar} -constraints {win|unix} -s
} -cleanup {
destroy .t .s
} -result {5.0}
test scrollbar-10.1.2 {<MouseWheel> event on scrollbar} -constraints {aqua} -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 -4
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 {
test scrollbar-10.2.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} -setup {
destroy .t .s
} -body {
pack [text .t -xscrollcommand {.s set} -wrap none] -side top
@@ -661,6 +728,20 @@ test scrollbar-10.2 {<MouseWheel> event on scrollbar} -constraints {win|unix} -s
} -cleanup {
destroy .t .s
} -result {1.4}
test scrollbar-10.2.2 {<MouseWheel> event on scrollbar} -constraints {aqua} -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 -4
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 {} {

53
tests/select.test
View File

@@ -333,7 +333,7 @@ test select-3.6 {Tk_OwnSelection procedure} -setup {
selection clear .f1
lappend result $lostSel
} -result {owned lost2}
test select-3.7 {Tk_OwnSelection procedure} -constraints unix -setup {
test select-3.7 {Tk_OwnSelection procedure} -constraints x11 -setup {
global lostSel
setup
setupbg
@@ -407,7 +407,7 @@ test select-4.3 {Tk_ClearSelection procedure} -setup {
} -body {
list [selection clear .f1] [selection clear .f1]
} -result {{} {}}
test select-4.4 {Tk_ClearSelection procedure} -constraints unix -setup {
test select-4.4 {Tk_ClearSelection procedure} -constraints x11 -setup {
global lostSel
setup
setupbg
@@ -439,7 +439,7 @@ test select-4.5 {Tk_ClearSelection procedure} -constraints {
list $lostSel $lostSel2
} -result {owned lost2}
test select-4.6 {Tk_ClearSelection procedure} -constraints {
unix altDisplay
x11 altDisplay
} -setup {
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
@@ -525,7 +525,7 @@ test select-5.8 {Tk_GetSelection procedure} -setup {
}} STRING}
list [selection get] $selInfo [catch {selection get} msg] $msg
} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}"
test select-5.9 {Tk_GetSelection procedure} -constraints unix -setup {
test select-5.9 {Tk_GetSelection procedure} -constraints x11 -setup {
setup
setupbg
} -body {
@@ -538,7 +538,7 @@ test select-5.9 {Tk_GetSelection procedure} -constraints unix -setup {
cleanupbg
lappend result $selInfo
} -result {{Test value} {TEST 0 4000}}
test select-5.10 {Tk_GetSelection procedure} -constraints unix -setup {
test select-5.10 {Tk_GetSelection procedure} -constraints x11 -setup {
setup
setupbg
} -body {
@@ -586,7 +586,7 @@ test select-5.12 {Tk_GetSelection procedure} -constraints {
$selInfo
} -result {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}}
test select-5.13 {Tk_GetSelection procedure} -constraints {
unix altDisplay
x11 altDisplay
} -setup {
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
@@ -607,7 +607,7 @@ test select-5.13 {Tk_GetSelection procedure} -constraints {
lappend result $selInfo
} -result {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}}
test select-5.14 {Tk_GetSelection procedure} -constraints {
unix altDisplay
x11 altDisplay
} -setup {
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
@@ -864,13 +864,14 @@ test select-7.1 {TkSelDeadWindow procedure} -constraints nonPortable -setup {
##############################################################################
# Check reentrancy on losing selection
test select-8.1 {TkSelEventProc procedure} -constraints unix -setup {
test select-8.1 {TkSelEventProc procedure} -constraints x11 -setup {
setup
setupbg
} -body {
selection own -selection CLIPBOARD -command {destroy .f1} .f1
update
dobg {selection own -selection CLIPBOARD .}
winfo children .
} -cleanup {
cleanupbg
} -result {}
@@ -880,7 +881,7 @@ test select-8.1 {TkSelEventProc procedure} -constraints unix -setup {
test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup {
setup
setupbg
} -constraints unix -body {
} -constraints x11 -body {
set selValue "1024"
set selInfo ""
selection handle -selection PRIMARY -format INTEGER -type TEST \
@@ -894,7 +895,7 @@ test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup {
test select-9.2 {SelCvtToX and SelCvtFromX procedures} -setup {
setup
setupbg
} -constraints unix -body {
} -constraints x11 -body {
set selValue "1024 0xffff 2048 -2 "
set selInfo ""
selection handle -selection PRIMARY -format INTEGER -type TEST \
@@ -907,7 +908,7 @@ test select-9.2 {SelCvtToX and SelCvtFromX procedures} -setup {
test select-9.3 {SelCvtToX and SelCvtFromX procedures} -setup {
setup
setupbg
} -constraints unix -body {
} -constraints x11 -body {
set selValue " "
set selInfo ""
selection handle -selection PRIMARY -format INTEGER -type TEST \
@@ -920,7 +921,7 @@ test select-9.3 {SelCvtToX and SelCvtFromX procedures} -setup {
test select-9.4 {SelCvtToX and SelCvtFromX procedures} -setup {
setup
setupbg
} -constraints unix -body {
} -constraints x11 -body {
set selValue "16 foobar 32"
set selInfo ""
selection handle -selection PRIMARY -format INTEGER -type TEST \
@@ -933,7 +934,7 @@ test select-9.4 {SelCvtToX and SelCvtFromX procedures} -setup {
test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup {
setup
setupbg
} -constraints unix -body {
} -constraints x11 -body {
# Ensure that lists of atoms are constructed correctly, even when the
# atom names have spaces in. [Bug 1353414]
set selValue "foo bar"
@@ -951,7 +952,7 @@ test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup {
# most control paths have been exercised above
test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints {
unix
x11
} -setup {
setup
} -body {
@@ -981,7 +982,7 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} -constr
catch {close $fd}
lappend x $selInfo
} -result {{1:PRIMARY selection doesn't exist or form "STRING" not defined} {}}
test select-10.2 {ConvertSelection procedure} -constraints unix -setup {
test select-10.2 {ConvertSelection procedure} -constraints x11 -setup {
setup
setupbg
} -body {
@@ -993,7 +994,7 @@ test select-10.2 {ConvertSelection procedure} -constraints unix -setup {
cleanupbg
lappend result $selInfo
} -result [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}]
test select-10.3 {ConvertSelection procedure} -constraints unix -setup {
test select-10.3 {ConvertSelection procedure} -constraints x11 -setup {
setup
setupbg
} -body {
@@ -1005,7 +1006,7 @@ test select-10.3 {ConvertSelection procedure} -constraints unix -setup {
# testing timers
# This one hangs in Exceed
test select-10.4 {ConvertSelection procedure} -constraints {
unix noExceed
x11 noExceed
} -setup {
setup
setupbg
@@ -1020,7 +1021,7 @@ test select-10.4 {ConvertSelection procedure} -constraints {
lappend result $selInfo
} -result {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}}
test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints {
unix
x11
} -setup {
setup
setupbg
@@ -1035,7 +1036,7 @@ test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints {
lappend result $selInfo
} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}}
test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints {
unix
x11
} -setup {
setup
setupbg
@@ -1058,7 +1059,7 @@ test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints {
##############################################################################
# testing reentrancy
test select-11.1 {TkSelPropProc procedure} -constraints unix -setup {
test select-11.1 {TkSelPropProc procedure} -constraints x11 -setup {
setup
setupbg
} -body {
@@ -1076,7 +1077,7 @@ test select-11.1 {TkSelPropProc procedure} -constraints unix -setup {
##############################################################################
# Note, this assumes we are using CurrentTtime
test select-12.1 {DefaultSelection procedure} -constraints unix -body {
test select-12.1 {DefaultSelection procedure} -constraints x11 -body {
setup
set result [selection get -type TIMESTAMP]
setupbg
@@ -1084,7 +1085,7 @@ test select-12.1 {DefaultSelection procedure} -constraints unix -body {
cleanupbg
set result
} -result {0x0 {0x0 }}
test select-12.2 {DefaultSelection procedure} -constraints unix -body {
test select-12.2 {DefaultSelection procedure} -constraints x11 -body {
setup
set result [lsort [list [selection get -type TARGETS]]]
setupbg
@@ -1092,7 +1093,7 @@ test select-12.2 {DefaultSelection procedure} -constraints unix -body {
cleanupbg
set result
} -result {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
test select-12.3 {DefaultSelection procedure} -constraints unix -body {
test select-12.3 {DefaultSelection procedure} -constraints x11 -body {
setup
selection handle .f1 {handler TEST} TEST
set result [list [lsort [selection get -type TARGETS]]]
@@ -1101,7 +1102,7 @@ test select-12.3 {DefaultSelection procedure} -constraints unix -body {
cleanupbg
set result
} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
test select-12.4 {DefaultSelection procedure} -constraints unix -setup {
test select-12.4 {DefaultSelection procedure} -constraints x11 -setup {
setup
set result ""
} -body {
@@ -1111,7 +1112,7 @@ test select-12.4 {DefaultSelection procedure} -constraints unix -setup {
cleanupbg
set result
} -result [list [winfo name .] [winfo name .]]
test select-12.5 {DefaultSelection procedure} -constraints unix -body {
test select-12.5 {DefaultSelection procedure} -constraints x11 -body {
setup
set result [selection get -type TK_WINDOW]
setupbg
@@ -1130,7 +1131,7 @@ test select-12.6 {DefaultSelection procedure} -body {
} -result {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
test select-13.1 {SelectionSize procedure, handler deleted} -constraints {
unix
x11
} -setup {
setup
setupbg

352
tests/text.test
View File

@@ -1587,6 +1587,15 @@ test text-8.27 {TextWidgetCmd procedure, "replace" option crash} -setup {
} -cleanup {
destroy .tt
} -result {}
test text-8.28 {TextWidgetCmd procedure, "replace" option crash} -setup {
text .tt
} -body {
.tt insert end "foo\n"
.tt tag add sel 1.0 end
.tt replace sel.first sel.last "bar"
} -cleanup {
destroy .tt
} -result {}
test text-9.1 {TextWidgetCmd procedure, "get" option} -setup {
@@ -5548,9 +5557,7 @@ test text-22.198 {TextSearchCmd, regexp search multi-line} -body {
} -cleanup {
destroy .t
} -result {2.0 19}
test text-22.199 {TextSearchCmd, regexp search multi-line} -constraints {
knownBug
} -body {
test text-22.199 {TextSearchCmd, regexp search multi-line} -body {
pack [text .t]
.t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
set foo {}
@@ -5559,9 +5566,7 @@ test text-22.199 {TextSearchCmd, regexp search multi-line} -constraints {
} -cleanup {
destroy .t
} -result {2.0 19}
test text-22.200 {TextSearchCmd, regexp search multi-line} -constraints {
knownBug
} -body {
test text-22.200 {TextSearchCmd, regexp search multi-line} -body {
pack [text .t]
.t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
set foo {}
@@ -5579,23 +5584,18 @@ test text-22.201 {TextSearchCmd, regexp search multi-line} -body {
} -cleanup {
destroy .t
} -result {1.0 24}
test text-22.202 {TextSearchCmd, regexp search multi-line} -constraints {
knownBug
} -body {
test text-22.202 {TextSearchCmd, regexp search multi-line} -body {
pack [text .t]
.t insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n"
list [.t search -regexp -backward -all -count foo \
-- {b+\n|a+\n(b+\n)+} end] $foo
-- {(b+\n|a+\n)(b+\n)+} end] $foo
} -cleanup {
destroy .t
} -result {1.0 25}
test text-22.203 {TextSearchCmd, regexp search multi-line} -constraints {
knownBug
} -body {
test text-22.203 {TextSearchCmd, regexp search multi-line} -body {
pack [text .t]
.t insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n"
.t search -regexp -backward -- {b+\n|a+\n(b+\n)+} end
# Should match at 1.0 for a true greedy match
.t search -regexp -backward -- {(b+\n|a+\n)(b+\n)+} end
} -cleanup {
destroy .t
} -result {1.0}
@@ -5864,7 +5864,219 @@ test text-22.225 {TextSearchCmd, strict limits} -body {
} -cleanup {
destroy .t
} -result {}
test text-22.226 {TextSearchCmd, exact search for the empty string} -body {
text .t
set res [.t search -count C "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.227 {TextSearchCmd, exact search for the empty string} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C "" 2.5]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.5 0}
test text-22.228 {TextSearchCmd, exact search all empty strings} -body {
text .t
set res [.t search -count C -all "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.229 {TextSearchCmd, exact search all empty strings} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -all "" 2.5 2.8]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.5 2.6 2.7 {0 0 0}}
test text-22.230 {TextSearchCmd, exact search all empty strings, with overlap} -body {
text .t
set res [.t search -count C -all -overlap "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.231 {TextSearchCmd, exact search all empty strings, with overlap} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -all -overlap "" 2.5 2.8]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.5 2.6 2.7 {0 0 0}}
test text-22.232 {TextSearchCmd, regexp search for the empty string} -body {
text .t
set res [.t search -count C -regexp "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.233 {TextSearchCmd, regexp search for the empty string} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -regexp "" 2.5]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.5 0}
test text-22.234 {TextSearchCmd, regexp search all empty strings} -body {
text .t
set res [.t search -count C -all -regexp "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.235 {TextSearchCmd, regexp search all empty strings} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -all -regexp "" 2.5 2.8]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.5 2.6 2.7 {0 0 0}}
test text-22.236 {TextSearchCmd, regexp search all empty strings, with overlap} -body {
text .t
set res [.t search -count C -all -regexp -overlap "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.237 {TextSearchCmd, regexp search all empty strings, with overlap} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -all -regexp -overlap "" 2.5 2.8]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.5 2.6 2.7 {0 0 0}}
test text-22.238 {TextSearchCmd, exact backwards search for the empty string} -body {
text .t
set res [.t search -count C -backwards "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.239 {TextSearchCmd, exact backwards search for the empty string} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -backwards "" 2.5]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.4 0}
test text-22.240 {TextSearchCmd, exact backwards search all empty strings} -body {
text .t
set res [.t search -count C -backwards -all "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.241 {TextSearchCmd, exact backwards search all empty strings} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -backwards -all "" 2.5 2.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.4 2.3 2.2 2.1 2.0 {0 0 0 0 0}}
test text-22.242 {TextSearchCmd, exact backwards search all empty strings, with overlap} -body {
text .t
set res [.t search -count C -backwards -all -overlap "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.243 {TextSearchCmd, exact backwards search all empty strings, with overlap} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -backwards -all -overlap "" 2.5 2.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.4 2.3 2.2 2.1 2.0 {0 0 0 0 0}}
test text-22.244 {TextSearchCmd, regexp backwards search for the empty string} -body {
text .t
set res [.t search -count C -backwards -regexp "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.245 {TextSearchCmd, regexpbackwards search for the empty string} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -backwards -regexp "" 2.5]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.4 0}
test text-22.246 {TextSearchCmd, regexp backwards search all empty strings} -body {
text .t
set res [.t search -count C -backwards -all -regexp "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.247 {TextSearchCmd, regexp backwards search all empty strings} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -backwards -all -regexp "" 2.5 2.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.4 2.3 2.2 2.1 2.0 {0 0 0 0 0}}
test text-22.248 {TextSearchCmd, regexp backwards search all empty strings, with overlap} -body {
text .t
set res [.t search -count C -backwards -all -regexp -overlap "" 1.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {1.0 0}
test text-22.249 {TextSearchCmd, regexp backwards search all empty strings, with overlap} -body {
text .t
.t insert end "Searching for the\nempty string!"
set res [.t search -count C -backwards -all -regexp -overlap "" 2.5 2.0]
lappend res $C
} -cleanup {
destroy .t
unset -nocomplain res C
} -result {2.4 2.3 2.2 2.1 2.0 {0 0 0 0 0}}
test text-22.250 {TextSearchCmd, backwards search all matching at start of line} -body {
text .t
.t insert end "abc"
set res [.t search -backwards -all b end] ; # works
lappend res [.t search -backwards a end] ; # works
lappend res [.t search -backwards -all a end] ; # used to hang
} -cleanup {
destroy .t
} -result {1.1 1.0 1.0}
test text-23.1 {TkTextGetTabs procedure} -setup {
text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
@@ -6395,9 +6607,9 @@ test text-27.14a {<<Modified>> virtual event - propagation to peers} -body {
} -cleanup {
destroy .t .tt
} -result {4}
test text-27.15 {<<Selection>> virtual event} -body {
test text-27.15 {<<Selection>> virtual event on sel tagging} -body {
set ::retval no_selection
pack [text .t -undo 1]
pack [text .t]
bind .t <<Selection>> "set ::retval selection_changed"
update idletasks
.t insert end "nothing special\n"
@@ -6407,6 +6619,110 @@ test text-27.15 {<<Selection>> virtual event} -body {
} -cleanup {
destroy .t
} -result {selection_changed}
test text-27.15a {<<Selection>> virtual event on sel removal} -body {
set ::retval no_selection
pack [text .t]
.t insert end "nothing special\n"
.t tag add sel 1.0 1.1
bind .t <<Selection>> "set ::retval selection_changed"
update idletasks
.t tag remove 1.0 end
update
set ::retval
} -cleanup {
destroy .t
} -result {selection_changed}
test text-27.15b {<<Selection>> virtual event on <<PasteSelection>> inside widget selection} -body {
pack [text .t]
.t insert end "There is a selection in this text widget,\n"
.t insert end "and it will be impacted by the <<PasteSelection>> event received.\n"
.t insert end "Therefore a <<Selection>> event must fire back."
.t tag add sel 1.0 1.28
bind .t <<Selection>> "set ::retval <<Selection>>_fired"
update
set ::retval no_<<Selection>>_event_fired
event generate .t <<PasteSelection>> -x 15 -y 3
update
set ::retval
} -cleanup {
destroy .t
} -result {<<Selection>>_fired}
test text-27.15c {No <<Selection>> virtual event on <<PasteSelection>> outside widget selection} -body {
pack [text .t]
.t insert end "There is a selection in this text widget,\n"
.t insert end "but it will not be impacted by the <<PasteSelection>> event received."
.t tag add sel 1.0 1.28
bind .t <<Selection>> "set ::retval <<Selection>>_fired"
update
set ::retval no_<<Selection>>_event_fired
event generate .t <<PasteSelection>> -x 15 -y 80
update
set ::retval
} -cleanup {
destroy .t
} -result {no_<<Selection>>_event_fired}
test text-27.15d {<<Selection>> virtual event on <Delete> with cursor inside selection} -body {
pack [text .t]
.t insert end "There is a selection in this text widget,\n"
.t insert end "and it will be impacted by the <Delete> event received.\n"
.t insert end "Therefore a <<Selection>> event must fire back."
.t tag add sel 1.0 1.28
bind .t <<Selection>> "set ::retval <<Selection>>_fired"
update
set ::retval no_<<Selection>>_event_fired
.t mark set insert 1.15
focus .t
event generate .t <Delete>
update
set ::retval
} -cleanup {
destroy .t
} -result {<<Selection>>_fired}
test text-27.15e {No <<Selection>> virtual event on <Delete> with cursor outside selection} -body {
pack [text .t]
.t insert end "There is a selection in this text widget,\n"
.t insert end "but it will not be impacted by the <Delete> event received."
.t tag add sel 1.0 1.28
bind .t <<Selection>> "set ::retval <<Selection>>_fired"
update
set ::retval no_<<Selection>>_event_fired
.t mark set insert 2.15
focus .t
event generate .t <Delete>
update
set ::retval
} -cleanup {
destroy .t
} -result {no_<<Selection>>_event_fired}
test text-27.15f {<<Selection>> virtual event on <<Cut>> with a widget selection} -body {
pack [text .t]
.t insert end "There is a selection in this text widget,\n"
.t insert end "and it will be impacted by the <<Cut>> event received.\n"
.t insert end "Therefore a <<Selection>> event must fire back."
.t tag add sel 1.0 1.28
bind .t <<Selection>> "set ::retval <<Selection>>_fired"
update
set ::retval no_<<Selection>>_event_fired
event generate .t <<Cut>>
update
set ::retval
} -cleanup {
destroy .t
} -result {<<Selection>>_fired}
test text-27.15g {No <<Selection>> virtual event on <<Cut>> without widget selection} -body {
pack [text .t]
.t insert end "There is a selection in this text widget,\n"
.t insert end "and it will be impacted by the <<Cut>> event received.\n"
.t insert end "Therefore a <<Selection>> event must fire back."
bind .t <<Selection>> "set ::retval <<Selection>>_fired"
update
set ::retval no_<<Selection>>_event_fired
event generate .t <<Cut>>
update
set ::retval
} -cleanup {
destroy .t
} -result {no_<<Selection>>_event_fired}
test text-27.16 {-maxundo configuration option} -body {
text .t -undo 1 -autoseparators 1 -maxundo 2
pack .t

10
tests/textDisp.test
View File

@@ -3374,6 +3374,16 @@ test textDisp-24.24 {TkTextCharLayoutProc, justification and tabs} {textfonts} {
.t tag add x 1.0 end
list [.t bbox 1.0] [.t bbox 1.10]
} [list [list 45 3 7 $fixedHeight] [list 94 3 7 $fixedHeight]]
test textDisp-24.25 {TkTextCharLayoutProc, justification and tabs} -constraints {textfonts} -setup {
text .tt -tabs {40 right} -wrap none -font $fixedFont
pack .tt
} -body {
.tt insert end \t9\n\t99\n\t999
update
list [.tt bbox 1.1] [.tt bbox 2.2] [.tt bbox 3.3]
} -cleanup {
destroy .tt
} -result [list [list 38 5 7 $fixedHeight] [list 38 20 7 $fixedHeight] [list 38 35 7 $fixedHeight]]
.t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \
-tabs 100

1
tests/textTag.test
View File

@@ -1746,6 +1746,7 @@ test textTag-18.1 {TkTextPickCurrent tag bindings} -setup {
text .t -width 30 -height 4 -relief sunken -borderwidth 10 \
-highlightthickness 10 -pady 2
pack .t
update ; # map the window, otherwise -warp can't be done
.t insert end " Tag here " TAG " no tag here"
.t tag configure TAG -borderwidth 4 -relief raised

425
tests/textWind.test
View File

@@ -11,28 +11,26 @@ namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
# Create entries in the option database to be sure that geometry options
# like border width have predictable values.
option add *Text.borderWidth 2
option add *Text.highlightThickness 2
option add *Text.font {Courier -12}
deleteWindows
# Widget used in tests 1.* - 16.*
text .t -width 30 -height 6 -bd 2 -highlightthickness 2
set fixedFont {"Courier New" -12}
set fixedHeight [font metrics $fixedFont -linespace]
set fixedWidth [font measure $fixedFont m]
set fixedAscent [font metrics $fixedFont -ascent]
# Widget used in almost all tests
set tWidth 30
set tHeight 6
text .t -width $tWidth -height $tHeight -bd 2 -highlightthickness 2 \
-font $fixedFont
pack .t -expand 1 -fill both
update
.t debug on
# 15 on XP, 13 on Solaris 8
set fixedHeight [font metrics {Courier -12} -linespace]
set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP
set color [expr {[winfo depth .t] > 1 ? "green" : "black"}]
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.
@@ -41,9 +39,16 @@ wm minsize . 1 1
wm positionfrom . user
wm deiconify .
set bw [.t cget -borderwidth]
set px [.t cget -padx]
set py [.t cget -pady]
set hlth [.t cget -highlightthickness]
set padx [expr {$bw+$px+$hlth}]
set pady [expr {$bw+$py+$hlth}]
# ----------------------------------------------------------------------
test textWind-1.1 {basic tests of options} -constraints fonts -setup {
test textWind-1.1 {basic tests of options} -setup {
.t delete 1.0 end
} -body {
.t insert end "This is the first line"
@@ -53,8 +58,13 @@ test textWind-1.1 {basic tests of options} -constraints fonts -setup {
update
list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \
[.t window configure .f -window]
} -result {1 3x3+19+23 {19 23 3 3} {-window {} {} {} .f}}
test textWind-1.2 {basic tests of options} -constraints fonts -setup {
} -result [list \
1 \
3x3+[expr {$padx+2*$fixedWidth}]+[expr {$pady+$fixedHeight+(($fixedHeight-3)/2)}] \
[list [expr {$padx+2*$fixedWidth}] [expr {$pady+$fixedHeight+(($fixedHeight-3)/2)}] 3 3] \
{-window {} {} {} .f}]
test textWind-1.2 {basic tests of options} -setup {
.t delete 1.0 end
} -body {
.t insert end "This is the first line"
@@ -64,7 +74,12 @@ test textWind-1.2 {basic tests of options} -constraints fonts -setup {
update
list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \
[.t window configure .f -align]
} -result {1 3x3+19+18 {19 18 3 3} {-align {} {} center top}}
} -result [list \
1 \
3x3+[expr {$padx+2*$fixedWidth}]+[expr {$pady+$fixedHeight}] \
[list [expr {$padx+2*$fixedWidth}] [expr {$pady+$fixedHeight}] 3 3] \
{-align {} {} center top}]
test textWind-1.3 {basic tests of options} -setup {
.t delete 1.0 end
} -body {
@@ -73,17 +88,23 @@ test textWind-1.3 {basic tests of options} -setup {
.t window create 2.2 -create "Test script"
.t window configure 2.2 -create
} -result {-create {} {} {} {Test script}}
test textWind-1.4 {basic tests of options} -constraints fonts -setup {
test textWind-1.4 {basic tests of options} -setup {
.t delete 1.0 end
} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
# the window .f should be wider than the fixed width
frame .f -width 10 -height 20 -bg $color
.t window create 2.2 -window .f -padx 5
update
list [winfo geom .f] [.t window configure .f -padx] [.t bbox 2.3]
} -result {10x20+24+18 {-padx {} {} 0 5} {39 21 7 13}}
test textWind-1.5 {basic tests of options} -constraints fonts -setup {
} -result [list \
10x20+[expr {$padx+2*$fixedWidth+5}]+[expr {$pady+$fixedHeight}] \
{-padx {} {} 0 5} \
[list [expr {$padx+2*$fixedWidth+10+2*5}] [expr {$pady+$fixedHeight+((20-$fixedHeight)/2)}] $fixedWidth $fixedHeight]]
test textWind-1.5 {basic tests of options} -setup {
.t delete 1.0 end
} -body {
.t insert end "This is the first line"
@@ -92,8 +113,12 @@ test textWind-1.5 {basic tests of options} -constraints fonts -setup {
.t window create 2.2 -window .f -pady 4
update
list [winfo geom .f] [.t window configure .f -pady] [.t bbox 2.31]
} -result {10x20+19+22 {-pady {} {} 0 4} {19 46 7 13}}
test textWind-1.6 {basic tests of options} -constraints fonts -setup {
} -result [list \
10x20+[expr {$padx+2*$fixedWidth}]+[expr {$pady+$fixedHeight+4}] \
{-pady {} {} 0 4} \
[list [expr {$padx+2*$fixedWidth}] [expr {$pady+$fixedHeight+20+2*4}] $fixedWidth $fixedHeight]]
test textWind-1.6 {basic tests of options} -setup {
.t delete 1.0 end
} -body {
.t insert end "This is the first line"
@@ -102,7 +127,9 @@ test textWind-1.6 {basic tests of options} -constraints fonts -setup {
.t window create 2.2 -window .f -stretch 1
update
list [winfo geom .f] [.t window configure .f -stretch]
} -result {5x13+19+18 {-stretch {} {} 0 1}}
} -result [list \
5x$fixedHeight+[expr {$padx+2*$fixedWidth}]+[expr {$pady+$fixedHeight}] \
{-stretch {} {} 0 1}]
.t delete 1.0 end
@@ -301,7 +328,8 @@ test textWind-3.1 {EmbWinConfigure procedure} -setup {
} -cleanup {
destroy .f
} -returnCodes error -result {unknown option "-foo"}
test textWind-3.2 {EmbWinConfigure procedure} -constraints fonts -setup {
test textWind-3.2 {EmbWinConfigure procedure} -setup {
destroy .f
} -body {
.t insert 1.0 "Some sample text"
@@ -314,7 +342,8 @@ test textWind-3.2 {EmbWinConfigure procedure} -constraints fonts -setup {
} -cleanup {
destroy .f
} -returnCodes error -result {bad text index ".f"}
test textWind-3.3 {EmbWinConfigure procedure} -constraints fonts -setup {
test textWind-3.3 {EmbWinConfigure procedure} -setup {
destroy .f
} -body {
.t insert 1.0 "Some sample text"
@@ -327,8 +356,10 @@ test textWind-3.3 {EmbWinConfigure procedure} -constraints fonts -setup {
list [winfo ismapped .f] [.t bbox 1.4]
} -cleanup {
destroy .f
} -result {0 {26 5 7 13}}
test textWind-3.4 {EmbWinConfigure procedure} -constraints fonts -setup {
} -result [list 0 \
[list [expr {$padx+3*$fixedWidth}] $pady $fixedWidth $fixedHeight]]
test textWind-3.4 {EmbWinConfigure procedure} -setup {
destroy .t.f
} -body {
.t insert 1.0 "Some sample text"
@@ -341,7 +372,8 @@ test textWind-3.4 {EmbWinConfigure procedure} -constraints fonts -setup {
} -cleanup {
destroy .t.f
} -returnCodes error -result {bad text index ".t.f"}
test textWind-3.5 {EmbWinConfigure procedure} -constraints fonts -setup {
test textWind-3.5 {EmbWinConfigure procedure} -setup {
destroy .t.f
} -body {
.t insert 1.0 "Some sample text"
@@ -354,8 +386,10 @@ test textWind-3.5 {EmbWinConfigure procedure} -constraints fonts -setup {
list [winfo ismapped .t.f] [.t bbox 1.4]
} -cleanup {
destroy .t.f
} -result {0 {26 5 7 13}}
test textWind-3.6 {EmbWinConfigure procedure} -constraints fonts -setup {
} -result [list 0 \
[list [expr {$padx+3*$fixedWidth}] $pady $fixedWidth $fixedHeight]]
test textWind-3.6 {EmbWinConfigure procedure} -setup {
destroy .f
} -body {
.t insert 1.0 "Some sample text"
@@ -367,7 +401,9 @@ test textWind-3.6 {EmbWinConfigure procedure} -constraints fonts -setup {
list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4]
} -cleanup {
destroy .f
} -result {0 1.3 1 {36 8 7 13}}
} -result [list 0 1.3 1 \
[list [expr {$padx+3*$fixedWidth+10}] [expr {$pady+((20-$fixedHeight)/2)}] $fixedWidth $fixedHeight]]
test textWind-3.7 {EmbWinConfigure procedure} -setup {
destroy .f
} -body {
@@ -450,19 +486,19 @@ test textWind-4.6 {AlignParseProc and AlignPrintProc procedures} -body {
.t window configure 1.0 -align
} -result {-align {} {} center top}
test textWind-5.1 {EmbWinStructureProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
.t insert 1.0 "Some sample text"
frame .f -width 10 -height 20 -bg $color
.t window create 1.2 -window .f
update
destroy .f
.t index .f
} -returnCodes error -result {bad text index ".f"}
test textWind-5.1 {EmbWinStructureProc procedure} -constraints fonts -setup {
.t delete 1.0 end
destroy .f
} -body {
.t insert 1.0 "Some sample text"
frame .f -width 10 -height 20 -bg $color
.t window create 1.2 -window .f
update
destroy .f
.t index .f
} -returnCodes error -result {bad text index ".f"}
test textWind-5.2 {EmbWinStructureProc procedure} -constraints fonts -setup {
test textWind-5.2 {EmbWinStructureProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -473,8 +509,11 @@ test textWind-5.2 {EmbWinStructureProc procedure} -constraints fonts -setup {
destroy .f
catch {.t index .f}
list [.t bbox 1.2] [.t bbox 1.3]
} -result {{19 11 0 0} {19 5 7 13}}
test textWind-5.3 {EmbWinStructureProc procedure} -constraints fonts -setup {
} -result [list \
[list [expr {$padx+2*$fixedWidth}] [expr {$pady+($fixedHeight/2)}] 0 0] \
[list [expr {$padx+2*$fixedWidth}] $pady $fixedWidth $fixedHeight]]
test textWind-5.3 {EmbWinStructureProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -486,7 +525,8 @@ test textWind-5.3 {EmbWinStructureProc procedure} -constraints fonts -setup {
destroy .f
.t index .f
} -returnCodes error -result {bad text index ".f"}
test textWind-5.4 {EmbWinStructureProc procedure} -constraints fonts -setup {
test textWind-5.4 {EmbWinStructureProc procedure} -setup {
.t delete 1.0 end
} -body {
.t insert 1.0 "Some sample text"
@@ -497,8 +537,11 @@ test textWind-5.4 {EmbWinStructureProc procedure} -constraints fonts -setup {
destroy .f
catch {.t index .f}
list [.t bbox 1.2] [.t bbox 1.3]
} -result {{19 18 0 0} {19 5 7 13}}
test textWind-5.5 {EmbWinStructureProc procedure} -constraints fonts -setup {
} -result [list \
[list [expr {$padx+2*$fixedWidth}] [expr {$pady+$fixedHeight}] 0 0] \
[list [expr {$padx+2*$fixedWidth}] $pady $fixedWidth $fixedHeight]]
test textWind-5.5 {EmbWinStructureProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -509,10 +552,12 @@ test textWind-5.5 {EmbWinStructureProc procedure} -constraints fonts -setup {
destroy .f
update
list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3]
} -result {0 1.2 {19 6 20 10} {39 5 7 13}}
} -result [list 0 1.2 \
[list [expr {$padx+2*$fixedWidth}] [expr {$pady+(($fixedHeight-10)/2)}] 20 10] \
[list [expr {$padx+2*$fixedWidth+20}] $pady $fixedWidth $fixedHeight]]
test textWind-6.1 {EmbWinRequestProc procedure} -constraints fonts -setup {
test textWind-6.1 {EmbWinRequestProc procedure} -setup {
.t delete 1.0 end
destroy .f
set result {}
@@ -525,12 +570,14 @@ test textWind-6.1 {EmbWinRequestProc procedure} -constraints fonts -setup {
lappend result [.t bbox 1.2] [.t bbox 1.3]
} -cleanup {
destroy .f
} -result {{19 5 10 20} {29 8 7 13} {19 5 25 30} {44 13 7 13}}
} -result [list \
[list [expr {$padx+2*$fixedWidth}] $pady 10 20] \
[list [expr {$padx+2*$fixedWidth+10}] [expr {$pady+((20-$fixedHeight)/2)}] $fixedWidth $fixedHeight] \
[list [expr {$padx+2*$fixedWidth}] $pady 25 30] \
[list [expr {$padx+2*$fixedWidth+25}] [expr {$pady+((30-$fixedHeight)/2)}] $fixedWidth $fixedHeight]]
test textWind-7.1 {EmbWinLostSlaveProc procedure} -constraints {
textfonts
} -setup {
test textWind-7.1 {EmbWinLostSlaveProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -543,10 +590,11 @@ test textWind-7.1 {EmbWinLostSlaveProc procedure} -constraints {
list [winfo geom .f] [.t bbox 1.2]
} -cleanup {
destroy .f
} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]]
test textWind-7.2 {EmbWinLostSlaveProc procedure} -constraints {
textfonts
} -setup {
} -result [list \
10x20+[expr {$padx+100}]+[expr {$pady+50}] \
[list [expr {$padx+2*$fixedWidth}] [expr {$pady+($fixedHeight/2)}] 0 0]]
test textWind-7.2 {EmbWinLostSlaveProc procedure} -setup {
.t delete 1.0 end
destroy .t.f
} -body {
@@ -559,10 +607,11 @@ test textWind-7.2 {EmbWinLostSlaveProc procedure} -constraints {
list [winfo geom .t.f] [.t bbox 1.2]
} -cleanup {
destroy .t.f
} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]]
} -result [list \
10x20+[expr {$padx+100}]+[expr {$pady+50}] \
[list [expr {$padx+2*$fixedWidth}] [expr {$pady+($fixedHeight/2)}] 0 0]]
test textWind-8.1 {EmbWinDeleteProc procedure} -constraints fonts -setup {
test textWind-8.1 {EmbWinDeleteProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -573,8 +622,12 @@ test textWind-8.1 {EmbWinDeleteProc procedure} -constraints fonts -setup {
set x XXX
.t delete 1.2
list $x [.t bbox 1.2] [.t bbox 1.3] [winfo exists .f]
} -result {destroyed {19 5 7 13} {26 5 7 13} 0}
test textWind-8.2 {EmbWinDeleteProc procedure} -constraints fonts -setup {
} -result [list destroyed \
[list [expr {$padx+2*$fixedWidth}] $pady $fixedWidth $fixedHeight] \
[list [expr {$padx+3*$fixedWidth}] $pady $fixedWidth $fixedHeight] \
0]
test textWind-8.2 {EmbWinDeleteProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -615,9 +668,8 @@ test textWind-10.1 {EmbWinLayoutProc procedure} -setup {
} -cleanup {
destroy .f
} -result {1 10 20 1.5}
test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} -constraints {
fonts
} -setup {
test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} -setup {
.t delete 1.0 end
proc bgerror args {
global msg
@@ -625,7 +677,7 @@ test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} -const
}
} -body {
.t insert 1.0 "Some sample text"
.t window create 1.5 -create {
.t window create 1.5 -create {
error "couldn't create window"
}
set msg xyzzy
@@ -633,10 +685,11 @@ test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} -const
list $msg [.t bbox 1.5]
} -cleanup {
rename bgerror {}
} -result {{{couldn't create window}} {40 11 0 0}}
test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} -constraints {
fonts
} -setup {
} -result [list \
{{couldn't create window}} \
[list [expr {$padx+5*$fixedWidth}] [expr {$pady+($fixedHeight/2)}] 0 0]]
test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} -setup {
.t delete 1.0 end
proc bgerror args {
global msg
@@ -652,26 +705,16 @@ test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} -const
list $msg [.t bbox 1.5]
} -cleanup {
rename bgerror {}
} -result {{{bad window path name "gorp"}} {40 11 0 0}}
.t delete 1.0 end
destroy .t.f
proc bgerror args {
global msg
if {[lsearch -exact $msg $args] == -1} {
lappend msg $args
}
}
} -result [list \
{{bad window path name "gorp"}} \
[list [expr {$padx+5*$fixedWidth}] [expr {$pady+($fixedHeight/2)}] 0 0]]
test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} -constraints {
textfonts
} -setup {
test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} -setup {
.t delete 1.0 end
destroy .t.f
proc bgerror args {
global msg
if {[lsearch -exact $msg $args] == -1} {
lappend msg $args
}
lappend msg $args
}
} -body {
.t insert 1.0 "Some sample text"
@@ -693,17 +736,17 @@ test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} -const
} -cleanup {
destroy .t.f
rename bgerror {}
} -result [list {{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0] 1]
test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} -constraints {
textfonts
} -setup {
} -result [list \
{{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} \
[list [expr {$padx+5*$fixedWidth}] [expr {$pady+($fixedHeight/2)}] 0 0] \
1]
test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} -setup {
.t delete 1.0 end
destroy .t.f
proc bgerror args {
global msg
if {[lsearch -exact $msg $args] == -1} {
lappend msg $args
}
lappend msg $args
}
} -body {
.t insert 1.0 "Some sample text"
@@ -718,10 +761,8 @@ test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} -const
destroy .t.f
rename bgerror {}
} -result {{{can't embed .t.f.f relative to .t}} 1}
catch {destroy .t.f}
test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} -constraints {
textfonts
} -setup {
test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} -setup {
.t delete 1.0 end
proc bgerror args {
global msg
@@ -731,6 +772,7 @@ test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} -const
}
} -body {
.t insert 1.0 "Some sample text"
update
.t window create 1.5 -create {
concat .t
}
@@ -739,17 +781,16 @@ test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} -const
lappend msg [.t bbox 1.5]
} -cleanup {
rename bgerror {}
} -result [list {{can't embed .t relative to .t}} [list 40 [expr {11+$fixedDiff/2}] 0 0]]
test textWind-10.7 {EmbWinLayoutProc procedure, error in creating window} -constraints {
textfonts
} -setup {
} -result [list \
{{can't embed .t relative to .t}} \
[list [expr {$padx+5*$fixedWidth}] [expr {$pady+($fixedHeight/2)}] 0 0]]
test textWind-10.7 {EmbWinLayoutProc procedure, error in creating window} -setup {
.t delete 1.0 end
destroy .t2
proc bgerror args {
global msg
if {[lsearch -exact $msg $args] == -1} {
lappend msg $args
}
lappend msg $args
}
} -body {
.t insert 1.0 "Some sample text"
@@ -763,15 +804,16 @@ test textWind-10.7 {EmbWinLayoutProc procedure, error in creating window} -const
lappend msg [.t bbox 1.5]
} -cleanup {
rename bgerror {}
} -result [list {{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0]]
} -result [list \
{{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} \
[list [expr {$padx+5*$fixedWidth}] [expr {$pady+($fixedHeight/2)}] 0 0]]
test textWind-10.8 {EmbWinLayoutProc procedure, error in creating window} -setup {
.t delete 1.0 end
destroy .t2
proc bgerror args {
global msg
if {[lsearch -exact $msg $args] == -1} {
lappend msg $args
}
lappend msg $args
}
} -body {
.t insert 1.0 "Some sample text"
@@ -804,9 +846,8 @@ test textWind-10.9 {EmbWinLayoutProc procedure, steal window from self} -setup {
} -cleanup {
destroy .t.b
} -result {1.3}
test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
fonts
} -setup {
test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -817,10 +858,11 @@ test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} -constrain
list [.t bbox .f] [.t bbox 1.13]
} -cleanup {
destroy .f
} -result {{89 5 126 20} {5 25 7 13}}
test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
fonts
} -setup {
} -result [list \
[list [expr {$padx+12*$fixedWidth}] $pady [expr {$tWidth*$fixedWidth-12*$fixedWidth}] 20] \
[list $padx [expr {$pady+20}] $fixedWidth $fixedHeight]]
test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -832,10 +874,11 @@ test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} -constrain
list [.t bbox .f] [.t bbox 1.13]
} -cleanup {
destroy .f
} -result {{89 5 126 20} {5 25 7 13}}
test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
fonts
} -setup {
} -result [list \
[list [expr {$padx+12*$fixedWidth}] $pady [expr {$tWidth*$fixedWidth-12*$fixedWidth}] 20] \
[list $padx [expr {$pady+20}] $fixedWidth $fixedHeight]]
test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -847,7 +890,10 @@ test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} -constrain
list [.t bbox .f] [.t bbox 1.13]
} -cleanup {
destroy .f
} -result {{5 18 127 20} {132 21 7 13}}
} -result [list \
[list $padx [expr {$pady+$fixedHeight}] 127 20] \
[list [expr {$padx+127}] [expr {$pady+$fixedHeight+((20-$fixedHeight)/2)}] $fixedWidth $fixedHeight]]
test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} -setup {
.t delete 1.0 end
destroy .f
@@ -860,10 +906,11 @@ test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} -setup {
list [.t bbox .f] [.t bbox 1.13]
} -cleanup {
destroy .f
} -result {{89 5 126 20} {}}
test textWind-10.14 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
fonts
} -setup {
} -result [list \
[list [expr {$padx+12*$fixedWidth}] $pady [expr {$tWidth*$fixedWidth-12*$fixedWidth}] 20] \
{}]
test textWind-10.14 {EmbWinLayoutProc procedure, doesn't fit on line} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -875,10 +922,11 @@ test textWind-10.14 {EmbWinLayoutProc procedure, doesn't fit on line} -constrain
list [.t bbox .f] [.t bbox 1.13]
} -cleanup {
destroy .f
} -result {{89 5 126 78} {}}
test textWind-10.15 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
fonts
} -setup {
} -result [list \
[list [expr {$padx+12*$fixedWidth}] $pady [expr {$tWidth*$fixedWidth-12*$fixedWidth}] [expr {$tHeight*$fixedHeight}]] \
{}]
test textWind-10.15 {EmbWinLayoutProc procedure, doesn't fit on line} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -890,8 +938,9 @@ test textWind-10.15 {EmbWinLayoutProc procedure, doesn't fit on line} -constrain
list [.t bbox .f] [.t bbox 1.13]
} -cleanup {
destroy .f
} -result {{5 18 210 65} {}}
} -result [list \
[list $padx [expr {$pady+$fixedHeight}] [expr {$tWidth*$fixedWidth}] [expr {($tHeight-1)*$fixedHeight}]] \
{}]
test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} -setup {
.t delete 1.0 end
@@ -909,7 +958,8 @@ test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} -setup {
} -cleanup {
destroy .f
place forget .t
} -result {30x20+119+55}
} -result [list 30x20+[expr {$padx+30+12*$fixedWidth}]+[expr {$pady+50}]]
test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} -setup {
.t delete 1.0 end
destroy .t.f
@@ -927,7 +977,8 @@ test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} -setup {
destroy .t.f
place forget .t
pack .t
} -result {30x20+89+5}
} -result [list 30x20+[expr {$padx+12*$fixedWidth}]+$pady]
test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} -setup {
.t delete 1.0 end
destroy .f
@@ -949,9 +1000,8 @@ test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} -se
place forget .t
pack .t
} -result {no configures}
test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints {
fonts
} -setup {
test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} -setup {
.t delete 1.0 end
destroy .f .f2
} -body {
@@ -969,10 +1019,12 @@ test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} -constrai
list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] [winfo ismapped .f2]
} -cleanup {
destroy .f .f2
} -result {1 30x20+103+18 {103 18 30 20} 0}
test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints {
fonts
} -setup {
} -result [list 1 \
30x20+[expr {$padx+14*$fixedWidth}]+[expr {$pady+$fixedHeight}] \
[list [expr {$padx+14*$fixedWidth}] [expr {$pady+$fixedHeight}] 30 20] \
0]
test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} -setup {
.t delete 1.0 end
destroy .f .f2
} -body {
@@ -990,10 +1042,11 @@ test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} -constrai
update
list [winfo ismapped .f] [winfo ismapped .f2] [winfo geom .f2] [.t bbox .f2]
} -cleanup {
destroy .f .f2
} -result {0 1 40x10+119+23 {119 23 40 10}}
.t configure -wrap char
destroy .f .f2
.t configure -wrap char
} -result [list 0 1 \
40x10+[expr {$padx+37*$fixedWidth+30-25*$fixedWidth}]+[expr {$pady+$fixedHeight+((20-10)/2)}] \
[list [expr {$padx+37*$fixedWidth+30-25*$fixedWidth}] [expr {$pady+$fixedHeight+((20-10)/2)}] 40 10]]
test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} -setup {
.t delete 1.0 end
@@ -1035,8 +1088,11 @@ test textWind-13.1 {EmbWinBboxProc procedure} -setup {
list [winfo geom .f] [.t bbox .f]
} -cleanup {
destroy .f
} -result {5x5+21+6 {21 6 5 5}}
test textWind-13.2 {EmbWinBboxProc procedure} -constraints fonts -setup {
} -result [list \
5x5+[expr {$padx+2*$fixedWidth+2}]+[expr {$pady+1}] \
[list [expr {$padx+2*$fixedWidth+2}] [expr {$pady+1}] 5 5]]
test textWind-13.2 {EmbWinBboxProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -1047,8 +1103,11 @@ test textWind-13.2 {EmbWinBboxProc procedure} -constraints fonts -setup {
list [winfo geom .f] [.t bbox .f]
} -cleanup {
destroy .f
} -result {5x5+21+9 {21 9 5 5}}
test textWind-13.3 {EmbWinBboxProc procedure} -constraints fonts -setup {
} -result [list \
5x5+[expr {$padx+2*$fixedWidth+2}]+[expr {$pady+1+(($fixedHeight-7)/2)}] \
[list [expr {$padx+2*$fixedWidth+2}] [expr {$pady+1+(($fixedHeight-7)/2)}] 5 5]]
test textWind-13.3 {EmbWinBboxProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -1059,8 +1118,11 @@ test textWind-13.3 {EmbWinBboxProc procedure} -constraints fonts -setup {
list [winfo geom .f] [.t bbox .f]
} -cleanup {
destroy .f
} -result {5x5+21+10 {21 10 5 5}}
test textWind-13.4 {EmbWinBboxProc procedure} -constraints fonts -setup {
} -result [list \
5x5+[expr {$padx+2*$fixedWidth+2}]+[expr {$pady+1+($fixedAscent-6)}] \
[list [expr {$padx+2*$fixedWidth+2}] [expr {$pady+1+($fixedAscent-6)}] 5 5]]
test textWind-13.4 {EmbWinBboxProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -1071,8 +1133,11 @@ test textWind-13.4 {EmbWinBboxProc procedure} -constraints fonts -setup {
list [winfo geom .f] [.t bbox .f]
} -cleanup {
destroy .f
} -result {5x5+21+12 {21 12 5 5}}
test textWind-13.5 {EmbWinBboxProc procedure} -constraints fonts -setup {
} -result [list \
5x5+[expr {$padx+2*$fixedWidth+2}]+[expr {$pady+1+($fixedHeight-7)}] \
[list [expr {$padx+2*$fixedWidth+2}] [expr {$pady+1+($fixedHeight-7)}] 5 5]]
test textWind-13.5 {EmbWinBboxProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -1083,8 +1148,11 @@ test textWind-13.5 {EmbWinBboxProc procedure} -constraints fonts -setup {
list [winfo geom .f] [.t bbox .f]
} -cleanup {
destroy .f
} -result {5x11+21+6 {21 6 5 11}}
test textWind-13.6 {EmbWinBboxProc procedure} -constraints fonts -setup {
} -result [list \
5x[expr {$fixedHeight-2}]+[expr {$padx+2*$fixedWidth+2}]+[expr {$pady+1}] \
[list [expr {$padx+2*$fixedWidth+2}] [expr {$pady+1}] 5 [expr {$fixedHeight-2}]]]
test textWind-13.6 {EmbWinBboxProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -1095,8 +1163,11 @@ test textWind-13.6 {EmbWinBboxProc procedure} -constraints fonts -setup {
list [winfo geom .f] [.t bbox .f]
} -cleanup {
destroy .f
} -result {5x11+21+6 {21 6 5 11}}
test textWind-13.7 {EmbWinBboxProc procedure} -constraints fonts -setup {
} -result [list \
5x[expr {$fixedHeight-2}]+[expr {$padx+2*$fixedWidth+2}]+[expr {$pady+1}] \
[list [expr {$padx+2*$fixedWidth+2}] [expr {$pady+1}] 5 [expr {$fixedHeight-2}]]]
test textWind-13.7 {EmbWinBboxProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -1107,8 +1178,11 @@ test textWind-13.7 {EmbWinBboxProc procedure} -constraints fonts -setup {
list [winfo geom .f] [.t bbox .f]
} -cleanup {
destroy .f
} -result {5x9+21+6 {21 6 5 9}}
test textWind-13.8 {EmbWinBboxProc procedure} -constraints fonts -setup {
} -result [list \
5x[expr {$fixedAscent-1}]+[expr {$padx+2*$fixedWidth+2}]+[expr {$pady+1}] \
[list [expr {$padx+2*$fixedWidth+2}] [expr {$pady+1}] 5 [expr {$fixedAscent-1}]]]
test textWind-13.8 {EmbWinBboxProc procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -1119,10 +1193,11 @@ test textWind-13.8 {EmbWinBboxProc procedure} -constraints fonts -setup {
list [winfo geom .f] [.t bbox .f]
} -cleanup {
destroy .f
} -result {5x11+21+6 {21 6 5 11}}
test textWind-13.9 {EmbWinBboxProc procedure, spacing options} -constraints {
fonts
} -setup {
} -result [list \
5x[expr {$fixedHeight-2}]+[expr {$padx+2*$fixedWidth+2}]+[expr {$pady+1}] \
[list [expr {$padx+2*$fixedWidth+2}] [expr {$pady+1}] 5 [expr {$fixedHeight-2}]]]
test textWind-13.9 {EmbWinBboxProc procedure, spacing options} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -1134,8 +1209,11 @@ test textWind-13.9 {EmbWinBboxProc procedure, spacing options} -constraints {
update
list [winfo geom .f] [.t bbox .f]
} -cleanup {
.t configure -spacing1 0 -spacing3 0
destroy .f
} -result {5x5+21+14 {21 14 5 5}}
} -result [list \
5x5+[expr {$padx+2*$fixedWidth+2}]+[expr {$pady+5+(($fixedHeight-5)/2)}] \
[list [expr {$padx+2*$fixedWidth+2}] [expr {$pady+5+(($fixedHeight-5)/2)}] 5 5]]
test textWind-14.1 {EmbWinDelayedUnmap procedure} -setup {
@@ -1157,6 +1235,7 @@ test textWind-14.1 {EmbWinDelayedUnmap procedure} -setup {
} -cleanup {
destroy .f
} -result {modified removed unmapped updated}
test textWind-14.2 {EmbWinDelayedUnmap procedure} -setup {
.t delete 1.0 end
destroy .f
@@ -1176,6 +1255,7 @@ test textWind-14.2 {EmbWinDelayedUnmap procedure} -setup {
} -cleanup {
destroy .f
} -result {modified deleted updated}
test textWind-14.3 {EmbWinDelayedUnmap procedure} -setup {
.t delete 1.0 end
destroy .f
@@ -1191,6 +1271,7 @@ test textWind-14.3 {EmbWinDelayedUnmap procedure} -setup {
} -cleanup {
destroy .f
} -result {1 0}
test textWind-14.4 {EmbWinDelayedUnmap procedure} -setup {
.t delete 1.0 end
destroy .t.f
@@ -1207,13 +1288,13 @@ test textWind-14.4 {EmbWinDelayedUnmap procedure} -setup {
destroy .t.f
} -result {1 0}
test textWind-15.1 {TkTextWindowIndex procedure} -setup {
.t delete 1.0 end
} -body {
.t index .foo
} -returnCodes error -result {bad text index ".foo"}
test textWind-15.2 {TkTextWindowIndex procedure} -constraints fonts -setup {
test textWind-15.2 {TkTextWindowIndex procedure} -setup {
.t delete 1.0 end
destroy .f
} -body {
@@ -1227,7 +1308,8 @@ test textWind-15.2 {TkTextWindowIndex procedure} -constraints fonts -setup {
list [.t index .f] [.t bbox 1.7]
} -cleanup {
destroy .f
} -result {1.6 {77 8 7 13}}
} -result [list 1.6 \
[list [expr {$padx+6*$fixedWidth+30}] [expr {$pady+((20-$fixedHeight)/2)}] $fixedWidth $fixedHeight]]
test textWind-16.1 {EmbWinTextStructureProc procedure} -setup {
@@ -1245,6 +1327,7 @@ test textWind-16.1 {EmbWinTextStructureProc procedure} -setup {
} -cleanup {
pack .t
} -result 0
test textWind-16.2 {EmbWinTextStructureProc procedure} -setup {
.t delete 1.0 end
destroy .f .f2
@@ -1263,7 +1346,12 @@ test textWind-16.2 {EmbWinTextStructureProc procedure} -setup {
lappend result [winfo geom .f] [.t bbox .f]
} -cleanup {
destroy .f .f2
} -result {30x20+47+5 {47 5 30 20} 30x20+47+35 {47 5 30 20}}
} -result [list \
30x20+[expr {$padx+6*$fixedWidth}]+$pady \
[list [expr {$padx+6*$fixedWidth}] $pady 30 20] \
30x20+[expr {$padx+6*$fixedWidth}]+[expr {$pady+30}] \
[list [expr {$padx+6*$fixedWidth}] $pady 30 20]]
test textWind-16.3 {EmbWinTextStructureProc procedure} -setup {
.t delete 1.0 end
} -body {
@@ -1276,6 +1364,7 @@ test textWind-16.3 {EmbWinTextStructureProc procedure} -setup {
} -cleanup {
pack .t
} -result {}
test textWind-16.4 {EmbWinTextStructureProc procedure} -setup {
.t delete 1.0 end
} -body {
@@ -1290,7 +1379,7 @@ test textWind-16.4 {EmbWinTextStructureProc procedure} -setup {
list [winfo ismapped .t.f] [.t bbox .t.f]
} -cleanup {
pack .t
} -result {1 {47 5 30 20}}
} -result [list 1 [list [expr {$padx+6*$fixedWidth}] $pady 30 20]]
test textWind-17.1 {peer widgets and embedded windows} -setup {

9
tests/ttk/checkbutton.test
View File

@@ -61,4 +61,13 @@ test checkbutton-1.7 "Button destroyed by click" -body {
update ; # shall not trigger error invalid command name ".top.b"
} -result {}
# Bug [fa8de77936]
test checkbutton-1.8 "Empty -variable" -body {
# shall simply not crash
ttk::checkbutton .cbev -variable {}
.cbev invoke
} -cleanup {
destroy .cbev
} -result {}
tcltest::cleanupTests

3
tests/ttk/layout.test
View File

@@ -21,5 +21,8 @@ test layout-1.1 "Size computations for mixed-orientation layouts" -body {
} -cleanup { destroy .b } -result [list 24 24]
test layout-2 "Empty -children not allowed" -body {
ttk::style layout Test.Tentry {Entry.field -children {}}
} -returnCodes error -result {Invalid -children value}
tcltest::cleanupTests

23
tests/ttk/scrollbar.test
View File

@@ -65,5 +65,28 @@ test scale-1.0 "Self-destruction" -body {
.s set 1 ; update
} -returnCodes 1 -match glob -result "*"
test scale-2.1 "-state option" -setup {
ttk::scale .s
set res ""
} -body {
# defaults
lappend res [.s instate disabled] [.s cget -state]
# set -state: instate returns accordingly
.s configure -state disabled
lappend res [.s instate disabled] [.s cget -state]
# back to normal
.s configure -state normal
lappend res [.s instate disabled] [.s cget -state]
# use state command: -state does NOT reflect it
.s state disabled
lappend res [.s instate disabled] [.s cget -state]
# further use state command
.s state readonly
lappend res [.s state] [.s cget -state]
} -cleanup {
destroy .s
unset -nocomplain res
} -result {0 normal 1 disabled 0 normal 1 normal {disabled readonly} normal}
tcltest::cleanupTests

36
tests/unixSelect.test
View File

@@ -108,7 +108,7 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
# ----------------------------------------------------------------------
test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints {
unix
x11
} -setup {
destroy .e
setupbg
@@ -124,7 +124,7 @@ test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints
} -result {4}
test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -140,7 +140,7 @@ test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} -
} -result \u00fc?
test unixSelect-1.3 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints {
unix
x11
} -setup {
setupbg
setup
@@ -160,7 +160,7 @@ test unixSelect-1.3 {TkSelGetSelection procedure: simple i18n text, iso2022} -co
} -result {1 2 {COMPOUND_TEXT 0 4000}}
test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -constraints {
unix
x11
} -setup {
setupbg
setup
@@ -186,7 +186,7 @@ test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -cons
} -result {1 8000 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}}
test unixSelect-1.5 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints {
unix
x11
} -setup {
setupbg
setup
@@ -206,7 +206,7 @@ test unixSelect-1.5 {TkSelGetSelection procedure: simple i18n text, iso2022} -co
} -result {1 2 {COMPOUND_TEXT 0 4000}}
test unixSelect-1.6 {TkSelGetSelection procedure: INCR i18n text} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -219,7 +219,7 @@ test unixSelect-1.6 {TkSelGetSelection procedure: INCR i18n text} -constraints {
} -result [expr {4 + [string length $longValue]}]
test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -235,7 +235,7 @@ test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} -constraints {
} -result [string repeat x 3999]\u00fc
test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -251,7 +251,7 @@ test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints {
} -result \u00fc[string repeat x 3999]
test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -270,7 +270,7 @@ test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints {
# from rearing its ugly head again.
test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -286,7 +286,7 @@ test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const
} -result [string repeat x 3999]\u00fc
test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -302,7 +302,7 @@ test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const
} -result \u00fc[string repeat x 3999]
test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -318,7 +318,7 @@ test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const
} -result [string repeat x 3999]\u00fc[string repeat x 4000]
test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints {
unix
x11
} -setup {
destroy .e
setupbg
@@ -334,7 +334,7 @@ test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -con
} -result {5}
test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -350,7 +350,7 @@ test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -con
} -result \u00fc\u0444
test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -366,7 +366,7 @@ test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const
} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21]
test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -382,7 +382,7 @@ test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const
} -result i[string repeat [string repeat \u00c4\u00e4 50]\n 21]
test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
unix
x11
} -setup {
setupbg
} -body {
@@ -400,7 +400,7 @@ test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const
} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21]
test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
unix
x11
} -setup {
setupbg
} -body {

12
tests/wm.test
View File

@@ -140,7 +140,7 @@ test wm-attributes-1.2.4 {usage} -constraints {unix notAqua} -returnCodes error
} -result {bad attribute "_": must be -alpha, -topmost, -zoomed, -fullscreen, or -type}
test wm-attributes-1.2.5 {usage} -constraints aqua -returnCodes error -body {
wm attributes . _
} -result {bad attribute "_": must be -alpha, -modified, -notify, or -titlepath}
} -result {bad attribute "_": must be -alpha, -fullscreen, -modified, -notify, -titlepath, -topmost, or -transparent}
### wm client ###
@@ -737,11 +737,11 @@ test wm-iconbitmap-1.2.2 {usage} -constraints win -returnCodes error -body {
test wm-iconbitmap-1.3 {usage} -constraints win -returnCodes error -body {
wm iconbitmap .t 12 13
} -result {illegal option "12" must be "-default"}
test wm-iconbitmap-1.4 {usage} -returnCodes error -body {
test wm-iconbitmap-1.4 {usage} -constraints notAqua -returnCodes error -body {
wm iconbitmap .t bad-bitmap
} -result {bitmap "bad-bitmap" not defined}
test wm-iconbitmap-2.1 {setting and reading values} -setup {
test wm-iconbitmap-2.1 {setting and reading values} -constraints notAqua -setup {
set result {}
} -body {
lappend result [wm iconbitmap .t]
@@ -1242,13 +1242,15 @@ test wm-resizable-1.5 {usage} -returnCodes error -body {
} -result {expected boolean value but got "bad"}
test wm-resizable-2.1 {setting and reading values} {
wm resizable .t 0 1
wm resizable .t 0 0
set result [wm resizable .t]
wm resizable .t 0 1
lappend result [wm resizable .t]
wm resizable .t 1 0
lappend result [wm resizable .t]
wm resizable .t 1 1
lappend result [wm resizable .t]
} {0 1 {1 0} {1 1}}
} {0 0 {0 1} {1 0} {1 1}}
### wm sizefrom ###