diff options
Diffstat (limited to 'tests')
38 files changed, 2013 insertions, 287 deletions
diff --git a/tests/bevel.tcl b/tests/bevel.tcl index 950b714..4af60f3 100644 --- a/tests/bevel.tcl +++ b/tests/bevel.tcl @@ -42,6 +42,7 @@ significance: r - should appear raised u - should appear raised and also slightly offset vertically s - should appear sunken +S - should appear solid n - preceding relief should extend right to end of line. * - should appear "normal" x - extra long lines to allow horizontal scrolling. @@ -125,15 +126,33 @@ foreach i {1 2 3} { .t.t insert end ***** .t.t insert end rrr r1 - - - - - - - - - - - +font configure TkFixedFont -size 20 +.t.t tag configure sol100 -relief solid -borderwidth 100 \ + -foreground red -font TkFixedFont +.t.t tag configure sol12 -relief solid -borderwidth 12 \ + -foreground red -font TkFixedFont +.t.t tag configure big -font TkFixedFont +set ind [.t.t index end] + +.t.t insert end "\n\nBorders do not leak on the neighbour chars" +.t.t insert end "\nOnly \"S\" is on dark background" +.t.t insert end { + xxx + x} {} S sol100 {x + xxx} + +.t.t insert end "\n\nA very thick border grows toward the inside of the tagged area only" +.t.t insert end "\nOnly \"S\" is on dark background" +.t.t insert end { + xxxx} {} SSSSS sol100 {xxxx + x} {} SSSSSSSSSSSSSSSSSS sol100 {x + xxx} {} SSSSSSSSS sol100 xxxx {} + +.t.t insert end "\n\nA thinner border is continuous" +.t.t insert end { + xxxx} {} SSSSS sol12 {xxxx + x} {} SSSSSSSSSSSSSSSSSS sol12 {x + xxx} {} SSSSSSSSS sol12 xxxx {} + +.t.t tag add big $ind end diff --git a/tests/bind.test b/tests/bind.test index c777d66..474771d 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -25,7 +25,6 @@ foreach event [bind all] { bind all $event {} } - proc unsetBindings {} { bind all <Enter> {} bind Test <Enter> {} @@ -2172,6 +2171,48 @@ test bind-16.44 {ExpandPercents procedure} -setup { destroy .t.f } -result {?? ??} +test bind-16.45 {ExpandPercents procedure} -setup { + set savedBind(Entry) [bind Entry <Key>] + set savedBind(All) [bind all <Key>] + entry .t.e + pack .t.e + focus -force .t.e + foreach p [event info] {event delete $p} + update +} -body { + bind .t.e <Key> {set x "%M"} + bind Entry <Key> {set y "%M"} + bind all <Key> {set z "%M"} + set x none; set y none; set z none + event gen .t.e <Key-a> + list $x $y $z +} -cleanup { + destroy .t.e + bind all <Key> $savedBind(All) + bind Entry <Key> $savedBind(Entry) + unset savedBind +} -result {0 1 2} +test bind-16.46 {ExpandPercents procedure} -setup { + set savedBind(All) [bind all <Key>] + set savedBind(Entry) [bind Entry <Key>] + entry .t.e + pack .t.e + focus -force .t.e + foreach p [event info] {event delete $p} + update +} -body { + bind all <Key> {set z "%M"} + bind Entry <Key> {set y "%M"} + bind .t.e <Key> {set x "%M"} + set x none; set y none; set z none + event gen .t.e <Key-a> + list $x $y $z +} -cleanup { + destroy .t.e + bind Entry <Key> $savedBind(Entry) + bind all <Key> $savedBind(All) + unset savedBind +} -result {0 1 2} test bind-17.1 {event command} -body { event diff --git a/tests/bitmap.test b/tests/bitmap.test index 80bc114..6e2573f 100644 --- a/tests/bitmap.test +++ b/tests/bitmap.test @@ -85,11 +85,11 @@ test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} -constraints { test bitmap-4.1 {FreeBitmapObjProc} -constraints { testbitmap } -body { - set x [format questhead] + set x [join questhead] button .b -bitmap $x - set y [format questhead] + set y [join questhead] .b configure -bitmap $y - set z [format questhead] + set z [join questhead] .b configure -bitmap $z set result {} lappend result [testbitmap questhead] diff --git a/tests/border.test b/tests/border.test index 78d0fcd..981e640 100644 --- a/tests/border.test +++ b/tests/border.test @@ -132,11 +132,11 @@ test border-3.1 {FreeBorderObjProc} -constraints { } -setup { set result {} } -body { - set x [format purple] + set x [join purple] button .b -bg $x -text .b1 - set y [format purple] + set y [join purple] .b configure -bg $y - set z [format purple] + set z [join purple] .b configure -bg $z lappend result [testborder purple] set x red diff --git a/tests/bugs.tcl b/tests/bugs.tcl index 83d9519..55e5f84 100644 --- a/tests/bugs.tcl +++ b/tests/bugs.tcl @@ -1,6 +1,6 @@ # This file is a Tcl script to test out various known bugs that will # cause Tk to crash. This file ends with .tcl instead of .test to make -# sure it isn't run when you type "source all". We currently are not +# sure it isn't run when you type "source all". We currently are not # shipping this file with the rest of the source release. # # Copyright (c) 1996 Sun Microsystems, Inc. diff --git a/tests/butGeom2.tcl b/tests/butGeom2.tcl index 96ff209..096225c 100644 --- a/tests/butGeom2.tcl +++ b/tests/butGeom2.tcl @@ -35,7 +35,7 @@ pack .t.anchorLabel .t.control.left.f -in .t.control.left -side top -anchor w foreach opt {activebackground activeforeground background disabledforeground foreground highlightbackground highlightcolor } { #button .t.color-$opt -text $opt -command "config -$opt \[tk_chooseColor]" menubutton .t.color-$opt -text $opt -menu .t.color-$opt.m -indicatoron 1 \ - -relief raised -bd 2 + -relief raised -bd 2 menu .t.color-$opt.m -tearoff 0 .t.color-$opt.m add command -label Red -command "config -$opt red" .t.color-$opt.m add command -label Green -command "config -$opt green" diff --git a/tests/canvPsGrph.tcl b/tests/canvPsGrph.tcl index 343979f..08ccd74 100644 --- a/tests/canvPsGrph.tcl +++ b/tests/canvPsGrph.tcl @@ -50,13 +50,13 @@ proc mkObjs c { $c create rect 380 200 420 240 -fill black $c create rect 200 330 240 370 -fill black } - + if {$what == "oval"} { $c create oval 50 10 150 80 -fill black -stipple gray25 -outline {} $c create oval 100 100 200 150 -outline {} -fill black -stipple gray50 $c create oval 250 100 400 300 -width .5c } - + if {$what == "poly"} { $c create poly 100 200 200 50 300 200 -smooth yes -stipple gray25 \ -outline black -width 4 @@ -68,7 +68,7 @@ proc mkObjs c { $c create poly 20 200 100 220 90 100 40 250 \ -fill {} -outline brown -width 3 } - + if {$what == "line"} { $c create line 20 20 120 20 -arrow both -width 5 $c create line 20 80 150 80 20 200 150 200 -smooth yes diff --git a/tests/canvPsImg.tcl b/tests/canvPsImg.tcl index c06aeaa..1f46eca 100644 --- a/tests/canvPsImg.tcl +++ b/tests/canvPsImg.tcl @@ -35,7 +35,7 @@ toplevel .t wm title .t "Postscript Tests for Canvases: Images" wm iconname .t "Postscript" -message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for images. Click the buttons below to select a Visual type for the canvas and colormode for the Postscript output. Then click "Print" to send the results to the default printer, or "Print to file" to put the Postscript output in a file called "/tmp/test.ps". You can also click on items in the canvas to delete them. +message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for images. Click the buttons below to select a Visual type for the canvas and colormode for the Postscript output. Then click "Print" to send the results to the default printer, or "Print to file" to put the Postscript output in a file called "/tmp/test.ps". You can also click on items in the canvas to delete them. NOTE: Some Postscript printers may not be able to handle Postscript generated in color mode.} -width 6i pack .t.m -side top -fill both diff --git a/tests/canvText.test b/tests/canvText.test index f0c677f..ff5e4b9 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -832,7 +832,7 @@ test canvText-16.1 {GetSelText procedure} -setup { test canvText-17.1 {TextToPostscript procedure} -setup { .c delete all - set result {/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont + set result {findfont [font actual $font -size] scalefont ISOEncode setfont 0.000 0.000 0.000 setrgbcolor AdjustColor 0 100 200 \[ \[(000)\] @@ -856,7 +856,7 @@ end .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax] .c itemconfig test -anchor n -fill black set x [.c postscript] - set x [string range $x [string first "/Courier-Oblique" $x] end] + set x [string range $x [string first "findfont " $x] end] expr {$x eq [subst $result] ? "ok" : $x} } -result ok @@ -873,6 +873,7 @@ test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} -setup { .c find enclosed 99 99 [expr $x2 + 1] [expr $y2 + 1] } -cleanup { destroy .c + unset -nocomplain bbox x2 y2 } -result 1 test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} -setup { diff --git a/tests/canvas.test b/tests/canvas.test index 5b6c0e4..e9184a5 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -539,10 +539,10 @@ test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} -setup { destroy .c pack [canvas .c] } -body { - set qx [expr {1.+1.}] - # qx has type double and no string representation + set qx [expr {1.+1.}] + # qx has type double and no string representation .c scale all $qx 0 1. 1. - # qx has now type MMRep and no string representation + # qx has now type MMRep and no string representation list $qx [string length $qx] } -result {2.0 3} test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup { @@ -551,9 +551,9 @@ test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup { } -body { set val 10 incr val - # qx has type double and no string representation + # qx has type double and no string representation .c scale all $val 0 1 1 - # qx has now type MMRep and no string representation + # qx has now type MMRep and no string representation incr val } -result 12 @@ -729,7 +729,7 @@ test canvas-15.19 "basic coords check: centimeters are larger than pixels" -setu destroy .c canvas .c } -body { - set id [.c create rect 0 0 1cm 1cm] + set id [.c create rect 0 0 1cm 1cm] expr {[lindex [.c coords $id] 2]>1} } -result {1} destroy .c diff --git a/tests/config.test b/tests/config.test index 8f7aa9f..a0c1921 100644 --- a/tests/config.test +++ b/tests/config.test @@ -16,8 +16,8 @@ proc killTables {} { # chain2 depends on chain1. If chain1 is deleted first, the # delete of chain2 will crash. deleteWindows - foreach t {alltypes chain2 chain1 configerror internal new notenoughparams - twowindows} { + foreach t {alltypes chain3 chain2 chain1 configerror internal + new notenoughparams twowindows} { while {[testobjconfig info $t] != ""} { testobjconfig delete $t } @@ -126,15 +126,15 @@ test config-2.1 {Tk_DeleteOptionTable - reference counts} -constraints { set x {} testobjconfig chain1 .a testobjconfig chain2 .b - testobjconfig chain2 .c + testobjconfig chain3 .c deleteWindows - testobjconfig delete chain2 + testobjconfig delete chain3 lappend x [testobjconfig info chain2] [testobjconfig info chain1] testobjconfig delete chain2 lappend x [testobjconfig info chain2] [testobjconfig info chain1] } -cleanup { killTables -} -result {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}} +} -result {{3 4 -three 2 2 -one} {2 2 -one} {} {2 2 -one}} # No tests for DestroyOptionHashTable; couldn't figure out how to test. diff --git a/tests/constraints.tcl b/tests/constraints.tcl index e28b159..6402753 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -38,7 +38,7 @@ namespace eval tk { } namespace eval bg { - # Manage a background process. + # Manage a background process. # Replace with slave interp or thread? namespace import ::tcltest::interpreter namespace import ::tk::test::loadTkCommand @@ -126,7 +126,7 @@ namespace eval tk { eval destroy [winfo children .] } - namespace export fixfocus + namespace export fixfocus proc fixfocus {} { catch {destroy .focus} toplevel .focus @@ -185,7 +185,7 @@ testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}] testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}] testConstraint userInteraction 0 testConstraint nonUnixUserInteraction [expr { - [testConstraint userInteraction] || + [testConstraint userInteraction] || ([testConstraint unix] && [testConstraint notAqua]) }] testConstraint haveDISPLAY [info exists env(DISPLAY)] @@ -207,7 +207,6 @@ testConstraint testembed [llength [info commands testembed]] testConstraint testfont [llength [info commands testfont]] testConstraint testmakeexist [llength [info commands testmakeexist]] testConstraint testmenubar [llength [info commands testmenubar]] -testConstraint testmenubar [llength [info commands testmenubar]] testConstraint testmetrics [llength [info commands testmetrics]] testConstraint testobjconfig [llength [info commands testobjconfig]] testConstraint testsend [llength [info commands testsend]] diff --git a/tests/cursor.test b/tests/cursor.test index 1039b52..ab7949e 100644 --- a/tests/cursor.test +++ b/tests/cursor.test @@ -145,11 +145,11 @@ test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} -constraints { test cursor-4.1 {FreeCursorObjProc} -constraints { testcursor } -body { - set x [format heart] + set x [join heart] button .b -cursor $x - set y [format heart] + set y [join heart] .b configure -cursor $y - set z [format heart] + set z [join heart] .b configure -cursor $z set result {} lappend result [testcursor heart] diff --git a/tests/entry.test b/tests/entry.test index 11408ac..d27ffb5 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -1892,6 +1892,19 @@ test entry-6.11 {EntryComputeGeometry procedure} -constraints { } -cleanup { destroy .e } -result {1 1 1} +test entry-6.12 {EntryComputeGeometry procedure} -constraints { + fonts +} -setup { + catch {destroy .e} + entry .e -font {Courier -12} -bd 2 -relief raised -width 20 + pack .e +} -body { + .e insert end "012\t456\t" + update + list [.e index @80] [.e index @81] [.e index @115] [.e index @116] +} -cleanup { + destroy .e +} -result {6 7 7 8} test entry-7.1 {InsertChars procedure} -setup { @@ -3447,8 +3460,6 @@ test entry-22.1 {lost namespaced textvar} -body { namespace eval test { variable foo {a b} } entry .e -textvariable ::test::foo namespace delete test - .e insert end "more stuff" - .e delete 5 end set ::test::foo } -cleanup { destroy .e @@ -3457,13 +3468,39 @@ test entry-22.2 {lost namespaced textvar} -body { namespace eval test { variable foo {a b} } entry .e -textvariable ::test::foo namespace delete test - .e insert end "more stuff" - .e delete 5 end - catch {set ::test::foo} - list [.e get] [.e cget -textvar] + catch {.e insert end "more stuff"} result1 + catch {.e delete 5 end } result2 + catch {set ::test::foo} result3 + list [.e get] [.e cget -textvar] $result1 $result2 $result3 +} -cleanup { + destroy .e +} -result [list "a bmo" ::test::foo \ + {can't set "::test::foo": parent namespace doesn't exist} \ + {can't set "::test::foo": parent namespace doesn't exist} \ + {can't read "::test::foo": no such variable}] + +test entry-23.1 {error in trace proc attached to the textvariable} -setup { + destroy .e +} -body { + trace variable myvar w traceit + proc traceit args {error "Intentional error here!"} + entry .e -textvariable myvar + catch {.e insert end mystring} result1 + catch {.e delete 0} result2 + list $result1 $result2 } -cleanup { destroy .e -} -result [list "a bmo" ::test::foo] +} -result [list {can't set "myvar": Intentional error here!} \ + {can't set "myvar": Intentional error here!}] + +test entry-24.1 {textvariable lives in a non-existing namespace} -setup { + destroy .e +} -body { + catch {entry .e -textvariable thisnsdoesntexist::myvar} result1 + set result1 +} -cleanup { + destroy .e +} -result {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist} # Gathered comments about lacks # XXX Still need to write tests for EntryBlinkProc, EntryFocusProc, diff --git a/tests/event.test b/tests/event.test index 1548467..756dbe5 100644 --- a/tests/event.test +++ b/tests/event.test @@ -756,9 +756,7 @@ test event-7.1(double-click) {A double click on a lone character deleteWindows } -result {1.3 A 1.3 A} test event-7.2(double-click) {A double click on a lone character - in an entry widget should select that character} -constraints { - knownBug -} -setup { + in an entry widget should select that character} -setup { deleteWindows } -body { set t [toplevel .t] @@ -822,7 +820,7 @@ test event-7.2(double-click) {A double click on a lone character return $result } -cleanup { deleteWindows -} -result {3 A 4 A} +} -result {4 A 4 A} # cleanup unset -nocomplain keypress_lookup diff --git a/tests/font.test b/tests/font.test index dff9fc9..9e44a93 100644 --- a/tests/font.test +++ b/tests/font.test @@ -12,17 +12,34 @@ eval tcltest::configure $argv tcltest::loadTestedCommands -catch {eval font delete [font names]} +set defaultfontlist [font names] + +proc getnondefaultfonts {} { + global defaultfontlist + set nondeffonts [list ] + foreach afont [font names] { + if {$afont ni $defaultfontlist} { + lappend nondeffonts $afont + } + } + set nondeffonts +} + +proc clearnondefaultfonts {} { + foreach afont [getnondefaultfonts] { + font delete $afont + } +} + deleteWindows # Toplevel used (in some tests) of the whole file toplevel .t wm geom .t +0+0 update idletasks -case [tk windowingsystem] { +switch [tk windowingsystem] { x11 {set fixed "fixed"} win32 {set fixed "courier 12"} - classic - aqua {set fixed "monaco 9"} } @@ -162,12 +179,12 @@ test font-5.4 {font command: configure: get all options} -setup { font delete xyz } -result xyz test font-5.5 {font command: configure: get one option} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts } -body { # (objc == 4) so objPtr = objv[3] font create xyz -family xyz font configure xyz -family - font names + getnondefaultfonts } -cleanup { font delete xyz } -result xyz @@ -193,34 +210,33 @@ test font-5.7 {font command: configure: bad option} -setup { test font-6.1 {font command: create: make up name} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts } -body { # (objc < 3) so name = NULL font create - font names + getnondefaultfonts } -cleanup { font delete font1 } -result {font1} test font-6.2 {font command: create: name specified} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts } -body { # not (objc < 3) font create xyz - font names + getnondefaultfonts } -cleanup { font delete xyz } -result {xyz} test font-6.3 {font command: create: name not really specified} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts } -body { # (name[0] == '-') so name = NULL font create -family xyz - font names + getnondefaultfonts } -cleanup { font delete font1 } -result {font1} test font-6.4 {font command: create: generate name} -setup { - catch {eval font delete [font names]} } -body { # (name == NULL) font create -family one @@ -230,7 +246,7 @@ test font-6.4 {font command: create: generate name} -setup { font create -family four font configure font2 -family } -cleanup { - catch {eval font delete [font names]} + font delete font1 font2 font3 } -result {four} test font-6.5 {font command: create: bad option creating new font} -setup { catch {font delete xyz} @@ -239,7 +255,7 @@ test font-6.5 {font command: create: bad option creating new font} -setup { font create xyz -xyz times } -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} test font-6.6 {font command: create: bad option creating new font} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts } -body { # name was not specified so skip = 2 font create -xyz times @@ -259,7 +275,7 @@ test font-7.1 {font command: delete: arguments} -body { font delete } -returnCodes error -result {wrong # args: should be "font delete fontname ?fontname ...?"} test font-7.2 {font command: delete: loop test} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts set x {} } -body { # for (i = 2; i < objc; i++) @@ -268,14 +284,14 @@ test font-7.2 {font command: delete: loop test} -setup { font create c -underline 1 font create d -underline 1 font create e -underline 1 - lappend x [lsort [font names]] + lappend x [lsort [getnondefaultfonts]] font delete a e c b - lappend x [lsort [font names]] + lappend x [lsort [getnondefaultfonts]] } -cleanup { - catch {eval font delete [font names]} + getnondefaultfonts } -result {{a b c d e} d} test font-7.3 {font command: delete: loop test} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts set x {} } -body { # (namedHashPtr == NULL) in middle of loop @@ -284,11 +300,11 @@ test font-7.3 {font command: delete: loop test} -setup { font create c -underline 1 font create d -underline 1 font create e -underline 1 - lappend x [lsort [font names]] + lappend x [lsort [getnondefaultfonts]] catch {font delete a d q c e b} - lappend x [lsort [font names]] + lappend x [lsort [getnondefaultfonts]] } -cleanup { - catch {eval font delete [font names]} + clearnondefaultfonts } -result {{a b c d e} {b c e}} test font-7.4 {font command: delete: non-existent} -setup { catch {font delete xyz} @@ -435,29 +451,29 @@ test font-11.1 {font command: names: arguments} -body { font names xyz } -returnCodes error -result {wrong # args: should be "font names"} test font-11.2 {font command: names: loop test: no passes} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts } -body { - font names + getnondefaultfonts } -result {} test font-11.3 {font command: names: loop test: one pass} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts } -body { font create - font names + getnondefaultfonts } -result {font1} test font-11.4 {font command: names: loop test: multiple passes} -setup { - catch {eval font delete [font names]} + clearnondefaultfonts } -body { font create xyz font create abc font create def - lsort [font names] + lsort [getnondefaultfonts] } -cleanup { - catch {eval font delete [font names]} + clearnondefaultfonts } -result {abc def xyz} test font-11.5 {font command: names: skip deletePending fonts} -setup { destroy .t.f - catch {eval font delete [font names]} + clearnondefaultfonts pack [label .t.f] update set x {} @@ -465,12 +481,12 @@ test font-11.5 {font command: names: skip deletePending fonts} -setup { # (nfPtr->deletePending == 0) font create xyz font create abc - lappend x [lsort [font names]] + lappend x [lsort [getnondefaultfonts]] .t.f config -font xyz font delete xyz - lappend x [font names] + lappend x [getnondefaultfonts] } -cleanup { - catch {eval font delete [font names]} + clearnondefaultfonts } -result {{abc xyz} abc} @@ -510,9 +526,9 @@ test font-13.1 {CreateNamedFont: new named font} -setup { set x {} } -body { # not (new == 0) - lappend x [font names] + lappend x [getnondefaultfonts] font create xyz - lappend x [font names] + lappend x [getnondefaultfonts] } -cleanup { font delete xyz } -result {{} xyz} @@ -647,7 +663,7 @@ test font-15.8 {Tk_AllocFontFromObj procedure: get native font} -constraints { win } -setup { destroy .t.f - catch {eval font delete [font names]} + clearnondefaultfonts pack [label .t.f] update } -body { @@ -753,7 +769,7 @@ test font-17.3 {Tk_FreeFont procedure: multiple ref} -setup { } -result {-family fixed} test font-17.4 {Tk_FreeFont procedure: named font} -setup { destroy .t.f - catch {eval font delete [font names]} + clearnondefaultfonts pack [label .t.f] update } -body { @@ -761,7 +777,7 @@ test font-17.4 {Tk_FreeFont procedure: named font} -setup { font create xyz .t.f config -font xyz destroy .t.f - font names + getnondefaultfonts } -result {xyz} test font-17.5 {Tk_FreeFont procedure: named font} -setup { destroy .t.f @@ -799,11 +815,11 @@ test font-18.1 {FreeFontObjProc} -constraints testfont -setup { destroy .b1 set result {} } -body { - set x [format {Courier 12}] + set x [join {Courier 12} { }] button .b1 -font $x - set y [format {Courier 12}] + set y [join {Courier 12} { }] .b1 configure -font $y - set z [format {Courier 12}] + set z [join {Courier 12} { }] .b1 configure -font $z lappend result [testfont counts {Courier 12}] set x red @@ -1510,11 +1526,11 @@ test font-24.10 {Tk_ComputeTextLayout: tab caused break} -body { set x {} .t.l config -text "000\t" update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}] lappend x [expr {[winfo reqheight .t.l] eq $ay}] .t.l config -text "000\t00" -wrap [expr $ax * 6] update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}] lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] return $x } -cleanup { @@ -2346,6 +2362,16 @@ test font-46.5 {font actual, too many chars} -body { font actual {times 10} 123456789012345678901234567890123456789012345678901 } -returnCodes error -result {expected a single character but got "1234567890123456789012345678901234567..."} +test font-47.1 {Bug f214b8ad5b} -body { + interp create one + interp create two + load {} Tk one + load {} Tk two + one eval menu .menubar + two eval menu .menubar + interp delete one + interp delete two +} -result {} # cleanup cleanupTests diff --git a/tests/imgPPM.test b/tests/imgPPM.test index 456427f..e3a738a 100644 --- a/tests/imgPPM.test +++ b/tests/imgPPM.test @@ -21,7 +21,7 @@ proc put {file data} { puts -nonewline $f $data close $f } - + test imgPPM-1.1 {FileReadPPM procedure} -body { put test.ppm "P6\n0 256\n255\nabcdef" image create photo p1 -file test.ppm @@ -39,9 +39,9 @@ test imgPPM-1.4 {FileReadPPM procedure} -body { image create photo p1 -file test.ppm } -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0} test imgPPM-1.5 {FileReadPPM procedure} -body { - put test.ppm "P6\n10 20\n256\nabcdef" + put test.ppm "P6\n10 20\n100000\nabcdef" image create photo p1 -file test.ppm -} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 256} +} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 100000} test imgPPM-1.6 {FileReadPPM procedure} -body { put test.ppm "P6\n10 20\n0\nabcdef" image create photo p1 -file test.ppm @@ -162,6 +162,71 @@ test imgPPM-4.1 {StringReadPPM procedure, data too short [Bug 1822391]} -body { image delete I } -returnCodes error -result {truncated PPM data} +test imgPPM-5.1 {StringReadPPM procedure} -setup { + image create photo ppm +} -body { + ppm put "P6\n0 256\n255\nabcdef" +} -returnCodes error -cleanup { + image delete ppm +} -result {PPM image data has dimension(s) <= 0} +test imgPPM-5.2 {StringReadPPM procedure} -setup { + image create photo ppm +} -body { + ppm put "P6\n-2 256\n255\nabcdef" +} -returnCodes error -cleanup { + image delete ppm +} -result {PPM image data has dimension(s) <= 0} +test imgPPM-5.3 {StringReadPPM procedure} -setup { + image create photo ppm +} -body { + ppm put "P6\n10 0\n255\nabcdef" +} -returnCodes error -cleanup { + image delete ppm +} -result {PPM image data has dimension(s) <= 0} +test imgPPM-5.4 {StringReadPPM procedure} -setup { + image create photo ppm +} -body { + ppm put "P6\n10 -2\n255\nabcdef" +} -returnCodes error -cleanup { + image delete ppm +} -result {PPM image data has dimension(s) <= 0} +test imgPPM-5.5 {StringReadPPM procedure} -setup { + image create photo ppm +} -body { + ppm put "P6\n10 20\n100000\nabcdef" +} -returnCodes error -cleanup { + image delete ppm +} -result {PPM image data has bad maximum intensity value 100000} +test imgPPM-5.6 {StringReadPPM procedure} -setup { + image create photo ppm +} -body { + ppm put "P6\n10 20\n0\nabcdef" +} -returnCodes error -cleanup { + image delete ppm +} -result {PPM image data has bad maximum intensity value 0} +test imgPPM-5.7 {StringReadPPM procedure} -setup { + image create photo ppm +} -body { + ppm put "P6\n10 10\n255\nabcdef" +} -returnCodes error -cleanup { + image delete ppm +} -result {truncated PPM data} +test imgPPM-5.8 {StringReadPPM procedure} -setup { + image create photo ppm +} -body { + ppm put "P6\n5 4\n255\n01234567890123456789012345678901234567890123456789012345678" +} -returnCodes error -cleanup { + image delete ppm +} -result {truncated PPM data} +test imgPPM-5.9 {StringReadPPM procedure} -setup { + image create photo ppm +} -body { + ppm put "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789" + list [image width ppm] [image height ppm] +} -cleanup { + image delete ppm +} -result {5 4} + imageFinish # cleanup @@ -169,3 +234,6 @@ catch {file delete test.ppm} cleanupTests return +# Local Variables: +# mode: tcl +# End: diff --git a/tests/listbox.test b/tests/listbox.test index 0805528..76a4349 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -57,6 +57,7 @@ proc mkPartial {{w .partial}} { # like border width have predictable values. option add *Listbox.borderWidth 2 +option add *Listbox.selectBorderWidth 1 option add *Listbox.highlightThickness 2 option add *Listbox.font {Helvetica -12 bold} @@ -203,6 +204,21 @@ test listbox-1.31 {configuration options} -body { } -cleanup { .l configure -highlightthickness [lindex [.l configure -highlightthickness] 3] } -result {0 0} +test listbox-1.32.1 {configuration options} -setup { + set res {} +} -body { + .l configure -justify left + set res [list [lindex [.l configure -justify] 4] [.l cget -justify]] + .l configure -justify center + lappend res [lindex [.l configure -justify] 4] [.l cget -justify] + .l configure -justify right + lappend res [lindex [.l configure -justify] 4] [.l cget -justify] +} -cleanup { + .l configure -justify [lindex [.l configure -justify] 3] +} -result {left left center center right right} +test listbox-1.32.2 {configuration options} -body { + .l configure -justify bogus +} -returnCodes error -result {bad justification "bogus": must be left, right, or center} test listbox-1.33 {configuration options} -body { .l configure -relief groove list [lindex [.l configure -relief] 4] [.l cget -relief] @@ -441,6 +457,58 @@ test listbox-3.18 {ListboxWidgetCmd procedure, "bbox" option, partial last line} mkPartial list [.partial.l bbox 3] [.partial.l bbox 4] } -result {{5 56 24 14} {5 73 23 14}} +test listbox-3.18a {ListboxWidgetCmd procedure, "bbox" option, justified} -constraints { + fonts +} -setup { + destroy .top.l .top + unset -nocomplain res +} -body { + toplevel .top + listbox .top.l -justify left + .top.l insert end Item1 LongerItem2 MuchLongerItem3 + pack .top.l + update + lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] + .top.l configure -justify center + lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] + .top.l configure -justify right + lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] +} -cleanup { + destroy .top.l .top + unset -nocomplain res +} -result [list \ + {5 5 34 14} {5 22 74 14} {5 39 106 14} \ + {58 5 34 14} {38 22 74 14} {22 39 106 14} \ + {111 5 34 14} {71 22 74 14} {39 39 106 14} \ +] +test listbox-3.18b {ListboxWidgetCmd procedure, "bbox" option, justified, non-default borderwidth} -setup { + destroy .top.l .top + unset -nocomplain lres res +} -body { + # This test checks whether all "x" values from bbox for different size + # items with different justification settings are all positive or zero + # This checks a bit the calculation of this x value with non-default + # borders widths of the listbox + toplevel .top + listbox .top.l -justify left -borderwidth 17 -highlightthickness 19 -selectborderwidth 22 + .top.l insert end Item1 LongerItem2 MuchLongerItem3 + .top.l selection set 1 + pack .top.l + update + lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] + .top.l configure -justify center + lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] + .top.l configure -justify right + lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] + set res 1 + for {set i 0} {$i < [llength $lres]} {incr i 4} { + set res [expr {$res * [expr {[lindex $lres $i] >= 0}] }] + } + set res +} -cleanup { + destroy .top.l .top + unset -nocomplain lres res +} -result {1} test listbox-3.19 {ListboxWidgetCmd procedure, "cget" option} -body { .l cget } -returnCodes error -result {wrong # args: should be ".l cget option"} @@ -455,7 +523,7 @@ test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} -body { } -result {0} test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} -body { llength [.l configure] -} -result {27} +} -result {28} test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} -body { .l configure -gorp } -returnCodes error -result {unknown option "-gorp"} @@ -3057,6 +3125,56 @@ test listbox-29.1 {listbox selection behavior, -state disabled} -setup { destroy .l } -result {1 1 2} +test listbox-30.1 {Bug 3607326} -setup { + destroy .l + unset -nocomplain a +} -body { + array set a {} + listbox .l -listvariable a +} -cleanup { + destroy .l + unset -nocomplain a +} -result * -match glob -returnCodes error + +test listbox-31.1 {<<ListboxSelect>> event} -setup { + destroy .l + unset -nocomplain res +} -body { + pack [listbox .l -state normal] + update + bind .l <<ListboxSelect>> {lappend res [%W curselection]} + .l insert end a b c + focus -force .l + event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires + .l configure -state disabled + focus -force .l + event generate .l <Control-Home> ; # <<ListboxSelect>> does NOT fire + .l configure -state normal + focus -force .l + event generate .l <Control-End> ; # <<ListboxSelect>> fires + .l selection clear 0 end ; # <<ListboxSelect>> does NOT fire + .l selection set 1 1 ; # <<ListboxSelect>> does NOT fire + lappend res [.l curselection] +} -cleanup { + destroy .l + unset -nocomplain res +} -result {0 2 1} + +test listbox-31.2 {<<ListboxSelect>> event on lost selection} -setup { + destroy .l +} -body { + pack [listbox .l -exportselection true] + update + bind .l <<ListboxSelect>> {lappend res [list [selection own] [%W curselection]]} + .l insert end a b c + focus -force .l + event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires + selection clear ; # <<ListboxSelect>> fires again + set res +} -cleanup { + destroy .l +} -result {{.l 0} {{} {}}} + resetGridInfo deleteWindows option clear diff --git a/tests/menu.test b/tests/menu.test index 595a21b..aaadc86 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -1548,10 +1548,15 @@ test menu-3.41 {MenuWidgetCmd procedure, "index" option} -setup { } -body { menu .m1 .m1 add command -label "test" - .m1 index "test" + .m1 add command -label "3" + .m1 add command -label "another label" + .m1 add command -label "end" + .m1 add command -label "3a" + .m1 add command -label "final entry" + list [.m1 index "test"] [.m1 index "3"] [.m1 index "3a"] [.m1 index "end"] } -cleanup { destroy .m1 -} -result {1} +} -result {1 3 5 6} test menu-3.42 {MenuWidgetCmd procedure, "insert" option} -setup { destroy .m1 } -body { @@ -3862,6 +3867,18 @@ test menu-35.1 {menu -underline string overruns Bug 1599877} -setup { deleteWindows } -result {} +test menu-37.1 {menubar menues cannot be posted - bug 2160206} -setup { + catch {destroy .m} +} -body { + # On Linux the following used to panic + # It now returns an error (on all platforms) + menu .m -type menubar + list [catch ".m post 1 1" msg] $msg +} -cleanup { + destroy .m +} -result {1 {a menubar menu cannot be posted}} + + # cleanup imageFinish deleteWindows diff --git a/tests/option.file1 b/tests/option.file1 index e64b6cc..32b4a18 100644 --- a/tests/option.file1 +++ b/tests/option.file1 @@ -14,4 +14,5 @@ ple # More comments, this time delimited by hash-marks. # Comment-line with space. *x6: +*x9: \ \ \\\101\n # comment line as last line of file. diff --git a/tests/option.file3 b/tests/option.file3 new file mode 100755 index 0000000..146cfd9 --- /dev/null +++ b/tests/option.file3 @@ -0,0 +1,18 @@ +! This file is a sample option (resource) database used to test +! Tk's option-handling capabilities. + +! Comment line \ + with a backslash-newline sequence embedded in it. + +*x1: blue + tktest.x2 : green +*\ +x3 \ + : pur\ +ple +*x 4: brówn +# More comments, this time delimited by hash-marks. + # Comment-line with space. +*x6: +*x9: \ \ \\\101\n +# comment line as last line of file. diff --git a/tests/option.test b/tests/option.test index 66df70c..ea5b5d1 100644 --- a/tests/option.test +++ b/tests/option.test @@ -384,30 +384,35 @@ test option-15.6 {database files} -body { option get . x6 color } -result {} test option-15.7 {database files} -body { + option read $option1 + option get . x9 color +} -result " \t\\A\n" +test option-15.8 {database files} -body { option read $option1 widget foo } -returnCodes error -result {wrong # args: should be "option readfile fileName ?priority?"} - -test option-15.8 {database files} -body { +test option-15.9 {database files} -body { option add *x3 burgundy catch {option read $option1 userDefault} option get . x3 color } -result burgundy -test option-15.9 {database files} -body { +test option-15.10 {database files} -body { set option2 [file join [testsDirectory] option.file2] option read $option2 } -returnCodes error -result {missing colon on line 2} - +set option3 [file join [testsDirectory] option.file3] +option read $option3 +test option-15.11 {database files} {option get . {x 4} color} br\xf3wn test option-16.1 {ReadOptionFile} -body { - set option3 [makeFile {} option.file3] - set file [open $option3 w] + set option4 [makeFile {} option.file3] + set file [open $option4 w] fconfigure $file -translation crlf puts $file "*x7: true\n*x8: false" close $file - option read $option3 userDefault + option read $option4 userDefault list [option get . x7 color] [option get . x8 color] } -cleanup { - removeFile $option3 + removeFile $option4 } -result {true false} deleteWindows diff --git a/tests/panedwindow.test b/tests/panedwindow.test index f2e01e8..666ed9c 100644 --- a/tests/panedwindow.test +++ b/tests/panedwindow.test @@ -98,168 +98,195 @@ test panedwindow-1.17 {configuration options: -orient (good)} -body { test panedwindow-1.18 {configuration options: -orient (bad)} -body { .p configure -orient badValue } -returnCodes error -result {bad orient "badValue": must be horizontal or vertical} -test panedwindow-1.19 {configuration options: -relief (good)} -body { +test panedwindow-1.19 {configuration options: -proxybackground (good)} -body { + .p configure -proxybackground "#f0a0a0" + list [lindex [.p configure -proxybackground] 4] [.p cget -proxybackground] +} -cleanup { + .p configure -proxybackground [lindex [.p configure -proxybackground] 3] +} -result {{#f0a0a0} #f0a0a0} +test panedwindow-1.20 {configuration options: -proxybackground (bad)} -body { + .p configure -proxybackground badValue +} -returnCodes error -result {unknown color name "badValue"} +test panedwindow-1.21 {configuration options: -proxyborderwidth (good)} -body { + .p configure -proxyborderwidth 1.3 + list [lindex [.p configure -proxyborderwidth] 4] [.p cget -proxyborderwidth] +} -cleanup { + .p configure -proxyborderwidth [lindex [.p configure -proxyborderwidth] 3] +} -result {1.3 1.3} +test panedwindow-1.22 {configuration options: -proxyborderwidth (bad)} -body { + .p configure -proxyborderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.23 {configuration options: -proxyrelief (good)} -body { + .p configure -proxyrelief groove + list [lindex [.p configure -proxyrelief] 4] [.p cget -proxyrelief] +} -cleanup { + .p configure -proxyrelief [lindex [.p configure -proxyrelief] 3] +} -result {groove groove} +test panedwindow-1.24 {configuration options: -proxyrelief (bad)} -body { + .p configure -proxyrelief 1.5 +} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test panedwindow-1.25 {configuration options: -relief (good)} -body { .p configure -relief groove list [lindex [.p configure -relief] 4] [.p cget -relief] } -cleanup { .p configure -relief [lindex [.p configure -relief] 3] } -result {groove groove} -test panedwindow-1.20 {configuration options: -relief (bad)} -body { +test panedwindow-1.26 {configuration options: -relief (bad)} -body { .p configure -relief 1.5 } -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} -test panedwindow-1.21 {configuration options: -sashcursor (good)} -body { +test panedwindow-1.27 {configuration options: -sashcursor (good)} -body { .p configure -sashcursor arrow list [lindex [.p configure -sashcursor] 4] [.p cget -sashcursor] } -cleanup { .p configure -sashcursor [lindex [.p configure -sashcursor] 3] } -result {arrow arrow} -test panedwindow-1.22 {configuration options: -sashcursor (bad)} -body { +test panedwindow-1.28 {configuration options: -sashcursor (bad)} -body { .p configure -sashcursor badValue } -returnCodes error -result {bad cursor spec "badValue"} -test panedwindow-1.23 {configuration options: -sashpad (good)} -body { +test panedwindow-1.29 {configuration options: -sashpad (good)} -body { .p configure -sashpad 1.3 list [lindex [.p configure -sashpad] 4] [.p cget -sashpad] } -cleanup { .p configure -sashpad [lindex [.p configure -sashpad] 3] } -result {1 1} -test panedwindow-1.24 {configuration options: -sashpad (bad)} -body { +test panedwindow-1.30 {configuration options: -sashpad (bad)} -body { .p configure -sashpad badValue } -returnCodes error -result {bad screen distance "badValue"} -test panedwindow-1.25 {configuration options: -sashrelief (good)} -body { +test panedwindow-1.31 {configuration options: -sashrelief (good)} -body { .p configure -sashrelief groove list [lindex [.p configure -sashrelief] 4] [.p cget -sashrelief] } -cleanup { .p configure -sashrelief [lindex [.p configure -sashrelief] 3] } -result {groove groove} -test panedwindow-1.26 {configuration options: -sashrelief (bad)} -body { +test panedwindow-1.32 {configuration options: -sashrelief (bad)} -body { .p configure -sashrelief 1.5 } -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} -test panedwindow-1.27 {configuration options: -sashwidth (good)} -body { +test panedwindow-1.33 {configuration options: -sashwidth (good)} -body { .p configure -sashwidth 10 list [lindex [.p configure -sashwidth] 4] [.p cget -sashwidth] } -cleanup { .p configure -sashwidth [lindex [.p configure -sashwidth] 3] } -result {10 10} -test panedwindow-1.28 {configuration options: -sashwidth (bad)} -body { +test panedwindow-1.34 {configuration options: -sashwidth (bad)} -body { .p configure -sashwidth badValue } -returnCodes error -result {bad screen distance "badValue"} -test panedwindow-1.29 {configuration options: -showhandle (good)} -body { +test panedwindow-1.35 {configuration options: -showhandle (good)} -body { .p configure -showhandle true list [lindex [.p configure -showhandle] 4] [.p cget -showhandle] } -cleanup { .p configure -showhandle [lindex [.p configure -showhandle] 3] } -result {1 1} -test panedwindow-1.30 {configuration options: -showhandle (bad)} -body { +test panedwindow-1.36 {configuration options: -showhandle (bad)} -body { .p configure -showhandle foo } -returnCodes error -result {expected boolean value but got "foo"} -test panedwindow-1.31 {configuration options: -width (good)} -body { +test panedwindow-1.37 {configuration options: -width (good)} -body { .p configure -width 402 list [lindex [.p configure -width] 4] [.p cget -width] } -cleanup { .p configure -width [lindex [.p configure -width] 3] } -result {402 402} -test panedwindow-1.32 {configuration options: -width (bad)} -body { +test panedwindow-1.38 {configuration options: -width (bad)} -body { .p configure -width badValue } -returnCodes error -result {bad screen distance "badValue"} -test panedwindow-1.33 {configuration options: -after (good)} -body { +test panedwindow-1.39 {configuration options: -after (good)} -body { .p paneconfigure .b -after .c list [lindex [.p paneconfigure .b -after] 4] \ [.p panecget .b -after] } -cleanup { .p paneconfig .b -after [lindex [.p paneconfig .b -after] 3] } -result {.c .c} -test panedwindow-1.34 {configuration options: -after (bad)} -body { +test panedwindow-1.40 {configuration options: -after (bad)} -body { .p paneconfigure .b -after badValue } -returnCodes error -result {bad window path name "badValue"} -test panedwindow-1.35 {configuration options: -before (good)} -body { +test panedwindow-1.41 {configuration options: -before (good)} -body { .p paneconfigure .b -before .c list [lindex [.p paneconfigure .b -before] 4] \ [.p panecget .b -before] } -cleanup { .p paneconfig .b -before [lindex [.p paneconfig .b -before] 3] } -result {.c .c} -test panedwindow-1.36 {configuration options: -before (bad)} -body { +test panedwindow-1.42 {configuration options: -before (bad)} -body { .p paneconfigure .b -before badValue } -returnCodes error -result {bad window path name "badValue"} -test panedwindow-1.37 {configuration options: -height (good)} -body { +test panedwindow-1.43 {configuration options: -height (good)} -body { .p paneconfigure .b -height 10 list [lindex [.p paneconfigure .b -height] 4] \ [.p panecget .b -height] } -cleanup { .p paneconfig .b -height [lindex [.p paneconfig .b -height] 3] } -result {10 10} -test panedwindow-1.38 {configuration options: -height (bad)} -body { +test panedwindow-1.44 {configuration options: -height (bad)} -body { .p paneconfigure .b -height badValue } -returnCodes error -result {bad screen distance "badValue"} -test panedwindow-1.39 {configuration options: -hide (good)} -body { +test panedwindow-1.45 {configuration options: -hide (good)} -body { .p paneconfigure .b -hide false list [lindex [.p paneconfigure .b -hide] 4] \ [.p panecget .b -hide] } -cleanup { .p paneconfig .b -hide [lindex [.p paneconfig .b -hide] 3] } -result {0 0} -test panedwindow-1.40 {configuration options: -hide (bad)} -body { +test panedwindow-1.46 {configuration options: -hide (bad)} -body { .p paneconfigure .b -hide foo } -returnCodes error -result {expected boolean value but got "foo"} -test panedwindow-1.41 {configuration options: -minsize (good)} -body { +test panedwindow-1.47 {configuration options: -minsize (good)} -body { .p paneconfigure .b -minsize 10 list [lindex [.p paneconfigure .b -minsize] 4] \ [.p panecget .b -minsize] } -cleanup { .p paneconfig .b -minsize [lindex [.p paneconfig .b -minsize] 3] } -result {10 10} -test panedwindow-1.42 {configuration options: -minsize (bad)} -body { +test panedwindow-1.48 {configuration options: -minsize (bad)} -body { .p paneconfigure .b -minsize badValue } -returnCodes error -result {bad screen distance "badValue"} -test panedwindow-1.43 {configuration options: -padx (good)} -body { +test panedwindow-1.49 {configuration options: -padx (good)} -body { .p paneconfigure .b -padx 1.3 list [lindex [.p paneconfigure .b -padx] 4] \ [.p panecget .b -padx] } -cleanup { .p paneconfig .b -padx [lindex [.p paneconfig .b -padx] 3] } -result {1 1} -test panedwindow-1.44 {configuration options: -padx (bad)} -body { +test panedwindow-1.50 {configuration options: -padx (bad)} -body { .p paneconfigure .b -padx badValue } -returnCodes error -result {bad screen distance "badValue"} -test panedwindow-1.45 {configuration options: -pady (good)} -body { +test panedwindow-1.51 {configuration options: -pady (good)} -body { .p paneconfigure .b -pady 1.3 list [lindex [.p paneconfigure .b -pady] 4] \ [.p panecget .b -pady] } -cleanup { .p paneconfig .b -pady [lindex [.p paneconfig .b -pady] 3] } -result {1 1} -test panedwindow-1.46 {configuration options: -pady (bad)} -body { +test panedwindow-1.52 {configuration options: -pady (bad)} -body { .p paneconfigure .b -pady badValue } -returnCodes error -result {bad screen distance "badValue"} -test panedwindow-1.47 {configuration options: -sticky (good)} -body { +test panedwindow-1.53 {configuration options: -sticky (good)} -body { .p paneconfigure .b -sticky nsew list [lindex [.p paneconfigure .b -sticky] 4] \ [.p panecget .b -sticky] } -cleanup { .p paneconfig .b -sticky [lindex [.p paneconfig .b -sticky] 3] } -result {nesw nesw} -test panedwindow-1.48 {configuration options: -sticky (bad)} -body { +test panedwindow-1.54 {configuration options: -sticky (bad)} -body { .p paneconfigure .b -sticky abcd } -returnCodes error -result {bad stickyness value "abcd": must be a string containing zero or more of n, e, s, and w} -test panedwindow-1.49 {configuration options: -stretch (good)} -body { +test panedwindow-1.55 {configuration options: -stretch (good)} -body { .p paneconfigure .b -stretch alw list [lindex [.p paneconfigure .b -stretch] 4] \ [.p panecget .b -stretch] } -cleanup { .p paneconfig .b -stretch [lindex [.p paneconfig .b -stretch] 3] } -result {always always} -test panedwindow-1.50 {configuration options: -stretch (bad)} -body { +test panedwindow-1.56 {configuration options: -stretch (bad)} -body { .p paneconfigure .b -stretch foo } -returnCodes error -result {bad stretch "foo": must be always, first, last, middle, or never} -test panedwindow-1.51 {configuration options: -width (good)} -body { +test panedwindow-1.57 {configuration options: -width (good)} -body { .p paneconfigure .b -width 10 list [lindex [.p paneconfigure .b -width] 4] \ [.p panecget .b -width] } -cleanup { .p paneconfig .b -width [lindex [.p paneconfig .b -width] 3] } -result {10 10} -test panedwindow-1.52 {configuration options: -width (bad)} -body { +test panedwindow-1.58 {configuration options: -width (bad)} -body { .p paneconfigure .b -width badValue } -returnCodes error -result {bad screen distance "badValue"} deleteWindows @@ -5087,6 +5114,27 @@ test panedwindow-25.1 {DestroyPanedWindow} -setup { } set result {} } -result {} +test panedwindow-25.2 {UnmapNotify and MapNotify events are propagated to slaves} -setup { + deleteWindows +} -body { + panedwindow .pw + .pw add [button .pw.b] + pack .pw + update + set result [winfo ismapped .pw.b] + pack forget .pw + update + lappend result [winfo ismapped .pw.b] + lappend result [winfo ismapped .pw] + pack .pw + update + lappend result [winfo ismapped .pw] + lappend result [winfo ismapped .pw.b] + destroy .pw .pw.b + set result +} -cleanup { + deleteWindows +} -result {1 0 0 1 1} test panedwindow-26.1 {PanedWindowIdentifyCoords} -setup { diff --git a/tests/scale.test b/tests/scale.test index 13ccb4d..a8d08a8 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -688,6 +688,11 @@ test scale-6.20 {ComputeFormat procedure} -body { .s set 1001.23456789 .s get } -result {1001.235} +test scale-6.21 {ComputeFormat procedure} -body { + .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 200 + .s set 1001.23456789 + .s get +} -result {1001.235} destroy .s @@ -1357,6 +1362,40 @@ test scale-18.3 {Scale button 2 events [Bug 787065]} -setup { } -result {0 {}} +test scale-19 {Bug [3529885fff] - Click in through goes in wrong direction} \ + -setup { + catch {destroy .s} + catch {destroy .s1 .s2 .s3 .s4} + unset -nocomplain x1 x2 x3 x4 x y + scale .s1 -from 0 -to 100 -resolution 1 -variable x1 -digits 4 -orient horizontal -length 100 + scale .s2 -from 0 -to 100 -resolution -1 -variable x2 -digits 4 -orient horizontal -length 100 + scale .s3 -from 100 -to 0 -resolution 1 -variable x3 -digits 4 -orient horizontal -length 100 + scale .s4 -from 100 -to 0 -resolution -1 -variable x4 -digits 4 -orient horizontal -length 100 + pack .s1 .s2 .s3 .s4 -side left + update + } \ + -body { + foreach {x y} [.s1 coord 50] {} + event generate .s1 <1> -x $x -y $y + event generate .s1 <ButtonRelease-1> -x $x -y $y + foreach {x y} [.s2 coord 50] {} + event generate .s2 <1> -x $x -y $y + event generate .s2 <ButtonRelease-1> -x $x -y $y + foreach {x y} [.s3 coord 50] {} + event generate .s3 <1> -x $x -y $y + event generate .s3 <ButtonRelease-1> -x $x -y $y + foreach {x y} [.s4 coord 50] {} + event generate .s4 <1> -x $x -y $y + event generate .s4 <ButtonRelease-1> -x $x -y $y + update + list $x1 $x2 $x3 $x4 + } \ + -cleanup { + unset x1 x2 x3 x4 x y + destroy .s1 .s2 .s3 .s4 + } \ + -result {1.0 1.0 1.0 1.0} + option clear # cleanup diff --git a/tests/scrollbar.test b/tests/scrollbar.test index 3addd28..3b16821 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -405,7 +405,7 @@ test scrollbar-3.73 {ScrollbarWidgetCmd procedure} { } {1 {bad option "bogus": must be activate, cget, configure, delta, fraction, get, identify, or set}} test scrollbar-3.74 {ScrollbarWidgetCmd procedure} { list [catch {.s c} msg] $msg -} {1 {bad option "c": must be activate, cget, configure, delta, fraction, get, identify, or set}} +} {1 {ambiguous option "c": must be activate, cget, configure, delta, fraction, get, identify, or set}} test scrollbar-4.1 {ScrollbarEventProc procedure} { catch {destroy .s1} @@ -632,6 +632,36 @@ 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 { + destroy .t .s +} -body { + pack [text .t -yscrollcommand {.s set}] -side left + for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"} + pack [scrollbar .s -command {.t yview}] -fill y -expand 1 -side left + update + focus -force .s + event generate .s <MouseWheel> -delta -120 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {5.0} + +test scrollbar-10.2 {<MouseWheel> event on scrollbar} -constraints {win|unix} -setup { + destroy .t .s +} -body { + pack [text .t -xscrollcommand {.s set} -wrap none] -side top + for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "} + pack [scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top + update + focus -force .s + event generate .s <Shift-MouseWheel> -delta -120 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {1.4} + catch {destroy .s} catch {destroy .t} diff --git a/tests/send.test b/tests/send.test index e3156a1..945d4d0 100644 --- a/tests/send.test +++ b/tests/send.test @@ -227,7 +227,7 @@ test send-8.3 {Tk_SendCmd procedure, options} {secureserver} { } {1 {no application named "-async"}} test send-8.4 {Tk_SendCmd procedure, options} {secureserver} { list [catch {send -gorp foo bar baz} msg] $msg -} {1 {bad option "-gorp": must be -async, -displayof, or --}} +} {1 {no application named "-gorp"}} test send-8.5 {Tk_SendCmd procedure, options} {secureserver} { list [catch {send -async foo} msg] $msg } {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}} diff --git a/tests/spinbox.test b/tests/spinbox.test index b8170c5..594cc90 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -3790,6 +3790,32 @@ test spinbox-23.1 {selection present while disabled, bug 637828} -body { destroy .e } -result {1 1 345} +test spinbox-24.1 {error in trace proc attached to the textvariable} -setup { + destroy .s +} -body { + trace variable myvar w traceit + proc traceit args {error "Intentional error here!"} + spinbox .s -textvariable myvar -from 1 -to 10 + catch {.s set mystring} result1 + catch {.s insert 0 mystring} result2 + catch {.s delete 0} result3 + catch {.s invoke buttonup} result4 + list $result1 $result2 $result3 $result4 +} -cleanup { + destroy .s +} -result [list {can't set "myvar": Intentional error here!} \ + {can't set "myvar": Intentional error here!} \ + {can't set "myvar": Intentional error here!} \ + {can't set "myvar": Intentional error here!}] + +test spinbox-25.1 {textvariable lives in a non-existing namespace} -setup { + destroy .s +} -body { + catch {spinbox .s -textvariable thisnsdoesntexist::myvar} result1 + set result1 +} -cleanup { + destroy .s +} -result {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist} # Collected comments about lacks from the test # XXX Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc, diff --git a/tests/text.test b/tests/text.test index 5089bb1..52a21af 100644 --- a/tests/text.test +++ b/tests/text.test @@ -925,7 +925,7 @@ test text-3.2 {TextWidgetCmd procedure} -setup { .t gorp 1.0 z 1.2 } -cleanup { destroy .t -} -returnCodes {error} -result {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview} +} -returnCodes {error} -result {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview} test text-4.1 {TextWidgetCmd procedure, "bbox" option} -setup { text .t @@ -1147,7 +1147,7 @@ Line 7" .t co 1.0 z 1.2 } -cleanup { destroy .t -} -returnCodes {error} -result {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview} +} -returnCodes {error} -result {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview} # "configure" option is already covered above test text-7.1 {TextWidgetCmd procedure, "debug" option} -setup { @@ -1163,7 +1163,7 @@ test text-7.2 {TextWidgetCmd procedure, "debug" option} -setup { .t de 0 1 } -cleanup { destroy .t -} -returnCodes {error} -result {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview} +} -returnCodes {error} -result {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview} test text-7.3 {TextWidgetCmd procedure, "debug" option} -setup { text .t } -body { @@ -2632,7 +2632,70 @@ test text-10.39 {TextWidgetCmd procedure, "count" option} -setup { lappend res [.t count -displaylines 1.19 3.24] [.t count -displaylines 1.0 end] } -cleanup { destroy .t -} -result {2 6 2 5} +} -result {2 6 1 5} +test text-9.2.45 {TextWidgetCmd procedure, "count" option} -setup { + text .t + pack .t + update + set res {} +} -body { + for {set i 1} {$i < 5} {incr i} { + .t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr 64+$i]]\n" + } + .t tag configure hidden -elide true + .t tag add hidden 2.15 3.10 + .t configure -wrap none + set res [.t count -displaylines 2.0 3.0] +} -cleanup { + destroy .t +} -result {0} +test text-9.2.46 {TextWidgetCmd procedure, "count" option} -setup { + toplevel .mytop + pack [text .mytop.t -font TkFixedFont -bd 0 -padx 0 -wrap char] + set spec [font measure TkFixedFont "Line 1+++Line 1---Li"] ; # 20 chars + append spec x300+0+0 + wm geometry .mytop $spec + .mytop.t delete 1.0 end + update + set res {} +} -body { + for {set i 1} {$i < 5} {incr i} { + # 0 1 2 3 4 + # 012345 678901234 567890123 456789012 34567890123456789 + .mytop.t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr 64+$i]]\n" + } + .mytop.t tag configure hidden -elide true + .mytop.t tag add hidden 2.30 3.10 + lappend res [.mytop.t count -displaylines 2.0 3.0] + lappend res [.mytop.t count -displaylines 2.0 3.50] +} -cleanup { + destroy .mytop +} -result {1 3} +test text-9.2.47 {TextWidgetCmd procedure, "count" option} -setup { + text .t + pack .t + update + set res {} +} -body { + for {set i 1} {$i < 25} {incr i} { + .t insert end "Line $i\n" + } + .t tag configure hidden -elide true + .t tag add hidden 5.7 11.0 + update + # next line to be fully sure that asynchronous line heights calculation is + # up-to-date otherwise this test may fail (depending on the computer + # performance), especially when the . toplevel has small height + .t sync + set y1 [lindex [.t yview] 1] + .t count -displaylines 5.0 11.0 + set y2 [lindex [.t yview] 1] + .t count -displaylines 5.0 12.0 + set y3 [lindex [.t yview] 1] + list [expr {$y1 == $y2}] [expr {$y1 == $y3}] +} -cleanup { + destroy .t +} -result {1 1} test text-11.1 {counting with tag priority eliding} -setup { @@ -2819,6 +2882,176 @@ test text-11.9 {counting with tag priority eliding} -setup { destroy .t } -result {1 0 0 1 0 2.0 4.0 4.0 4.0 3.0 3.0 3.0 2.0 1.0 1.0} +test text-11a.1 {TextWidgetCmd procedure, "pendingsync" option} -setup { + destroy .yt +} -body { + text .yt + list [catch {.yt pendingsync mytext} msg] $msg +} -cleanup { + destroy .yt +} -result {1 {wrong # args: should be ".yt pendingsync"}} +test text-11a.2 {TextWidgetCmd procedure, "pendingsync" option} -setup { + destroy .top.yt .top +} -body { + toplevel .top + pack [text .top.yt] + set content {} + for {set i 1} {$i < 300} {incr i} { + append content [string repeat "$i " 15] \n + } + .top.yt insert 1.0 $content + # wait for end of line metrics calculation to get correct $fraction1 + # as a reference + while {[.top.yt pendingsync]} {update} + .top.yt yview moveto 1 + set fraction1 [lindex [.top.yt yview] 0] + set res [expr {$fraction1 > 0}] + .top.yt delete 1.0 end + .top.yt insert 1.0 $content + # ensure the test is relevant + lappend res [.top.yt pendingsync] + # asynchronously wait for completion of line metrics calculation + while {[.top.yt pendingsync]} {update} + .top.yt yview moveto $fraction1 + set fraction2 [lindex [.top.yt yview] 0] + lappend res [expr {$fraction1 == $fraction2}] +} -cleanup { + destroy .top.yt .top +} -result {1 1 1} + +test text-11a.11 {TextWidgetCmd procedure, "sync" option} -setup { + destroy .yt +} -body { + text .yt + list [catch {.yt sync mytext} msg] $msg +} -cleanup { + destroy .yt +} -result {1 {wrong # args: should be ".yt sync ?-command command?"}} +test text-11a.12 {TextWidgetCmd procedure, "sync" option} -setup { + destroy .top.yt .top +} -body { + toplevel .top + pack [text .top.yt] + set content {} + for {set i 1} {$i < 30} {incr i} { + append content [string repeat "$i " 15] \n + } + .top.yt insert 1.0 $content + # wait for end of line metrics calculation to get correct $fraction1 + # as a reference + .top.yt sync + .top.yt yview moveto 1 + set fraction1 [lindex [.top.yt yview] 0] + set res [expr {$fraction1 > 0}] + # first case: do not wait for completion of line metrics calculation + .top.yt delete 1.0 end + .top.yt insert 1.0 $content + .top.yt yview moveto $fraction1 + set fraction2 [lindex [.top.yt yview] 0] + lappend res [expr {$fraction1 == $fraction2}] + # second case: wait for completion of line metrics calculation + .top.yt delete 1.0 end + .top.yt insert 1.0 $content + .top.yt sync + .top.yt yview moveto $fraction1 + set fraction2 [lindex [.top.yt yview] 0] + lappend res [expr {$fraction1 == $fraction2}] +} -cleanup { + destroy .top.yt .top +} -result {1 0 1} + +test text-11a.21 {TextWidgetCmd procedure, "sync" option with -command} -setup { + destroy .yt +} -body { + text .yt + list [catch {.yt sync -comx foo} msg] $msg +} -cleanup { + destroy .yt +} -result {1 {wrong option "-comx": should be "-command"}} +test text-11a.22 {TextWidgetCmd procedure, "sync" option with -command} -setup { + destroy .top.yt .top +} -body { + set res {} + set ::x 0 + toplevel .top + pack [text .top.yt] + set content {} + for {set i 1} {$i < 30} {incr i} { + append content [string repeat "$i " 15] \n + } + .top.yt insert 1.0 $content + # first case: line metrics calculation still running when launching 'sync -command' + lappend res [.top.yt pendingsync] + .top.yt sync -command [list set ::x 1] + lappend res $::x + # now finish line metrics calculations + while {[.top.yt pendingsync]} {update} + lappend res [.top.yt pendingsync] $::x + # second case: line metrics calculation completed when launching 'sync -command' + .top.yt sync -command [list set ::x 2] + lappend res $::x + vwait ::x + lappend res $::x +} -cleanup { + destroy .top.yt .top +} -result {1 0 0 1 1 2} + +test text-11a.31 {"<<WidgetViewSync>>" event} -setup { + destroy .top.yt .top +} -body { + toplevel .top + pack [text .top.yt] + set content {} + for {set i 1} {$i < 300} {incr i} { + append content [string repeat "$i " 15] \n + } + .top.yt insert 1.0 $content + update + bind .top.yt <<WidgetViewSync>> { if {%d} {set yud(%W) 1} } + # wait for end of line metrics calculation to get correct $fraction1 + # as a reference + if {[.top.yt pendingsync]} {vwait yud(.top.yt)} + .top.yt yview moveto 1 + set fraction1 [lindex [.top.yt yview] 0] + set res [expr {$fraction1 > 0}] + .top.yt delete 1.0 end + .top.yt insert 1.0 $content + # synchronously wait for completion of line metrics calculation + # and ensure the test is relevant + set waited 0 + if {[.top.yt pendingsync]} {set waited 1 ; vwait yud(.top.yt)} + lappend res $waited + .top.yt yview moveto $fraction1 + set fraction2 [lindex [.top.yt yview] 0] + lappend res [expr {$fraction1 == $fraction2}] +} -cleanup { + destroy .top.yt .top +} -result {1 1 1} + +test text-11a.41 {"sync" "pendingsync" and <<WidgetViewSync>>} -setup { + destroy .top.yt .top +} -body { + set res {} + toplevel .top + pack [text .top.yt] + set content {} + for {set i 1} {$i < 300} {incr i} { + append content [string repeat "$i " 50] \n + } + bind .top.yt <<WidgetViewSync>> {lappend res Sync:%d} + .top.yt insert 1.0 $content + vwait res ; # event dealt with by the event loop, with %d==0 i.e. we're out of sync + # ensure the test is relevant + lappend res "Pending:[.top.yt pendingsync]" + # - <<WidgetViewSync>> fires when sync returns if there was pending syncs + # - there is no more any pending sync after running 'sync' + .top.yt sync + vwait res ; # event dealt with by the event loop, with %d==1 i.e. we're in sync again + lappend res "Pending:[.top.yt pendingsync]" + set res +} -cleanup { + destroy .top.yt .top +} -result {Sync:0 Pending:1 Sync:1 Pending:0} test text-12.1 {TextWidgetCmd procedure, "index" option} -setup { text .t @@ -2840,7 +3073,7 @@ test text-12.3 {TextWidgetCmd procedure, "index" option} -setup { .t in a b } -cleanup { destroy .t -} -returnCodes {error} -result {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview} +} -returnCodes {error} -result {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview} test text-12.4 {TextWidgetCmd procedure, "index" option} -setup { text .t } -body { @@ -3440,9 +3673,10 @@ Line 4" list [.t tag ranges sel] [.t get 1.0 end] } -cleanup { destroy .t -} -result {{1.0 3.5} {Line 1 +} -result {{1.0 4.0} {Line 1 abcde 12345 + }} test text-19.9 {DeleteChars procedure} -body { text .t @@ -5498,6 +5732,27 @@ test text-22.217 {TextSearchCmd, elide up to match} -setup { } -cleanup { destroy .t } -result {{} {} 1.0 2.1 2.0 3.1 2.0 3.0} +test text-22.217.1 {elide up to match, with UTF-8 chars before the match} -setup { + pack [text .t] + set res {} +} -body { + .t tag configure e -elide 0 + .t insert end A {} xyz e bb\n + .t insert end \u00c4 {} xyz e bb + set res {} + lappend res [.t search bb 1.0 "1.0 lineend"] + lappend res [.t search bb 2.0 "2.0 lineend"] + lappend res [.t search -regexp bb 1.0 "1.0 lineend"] + lappend res [.t search -regexp bb 2.0 "2.0 lineend"] + .t tag configure e -elide 1 + lappend res [.t search bb 1.0 "1.0 lineend"] + lappend res [.t search bb 2.0 "2.0 lineend"] + lappend res [.t search -regexp bb 1.0 "1.0 lineend"] + lappend res [.t search -regexp -elide bb 2.0 "2.0 lineend"] + lappend res [.t search -regexp bb 2.0 "2.0 lineend"] +} -cleanup { + destroy .t +} -result {1.4 2.4 1.4 2.4 1.4 2.4 1.4 2.4 2.4} test text-22.218 {TextSearchCmd, strict limits} -body { pack [text .t] .t insert 1.0 "Hello world!\nThis is a test\n" @@ -6113,6 +6368,95 @@ test text-27.18 {patch 1469210 - inserting after undo} -setup { } -cleanup { destroy .t } -result 1 +test text-25.19 {patch 1669632 (i) - undo after <Control-1>} -setup { + destroy .t +} -body { + text .t -undo 1 + .t insert end foo\nbar + .t edit reset + .t insert 2.2 WORLD + event generate .t <Control-1> -x 1 -y 1 + .t insert insert HELLO + .t edit undo + .t get 2.2 2.7 +} -cleanup { + destroy .t +} -result WORLD +test text-25.20 {patch 1669632 (iv) - undo after <<SelectNone>>} -setup { + destroy .top .top.t +} -body { + toplevel .top + pack [text .top.t -undo 1] + .top.t insert end "This is an example text" + .top.t edit reset + .top.t mark set insert 1.5 + .top.t insert 1.5 HELLO + .top.t tag add sel 1.10 1.12 + update + focus -force .top.t + event generate .top.t <<SelectNone>> + .top.t insert insert " WORLD " + .top.t edit undo + .top.t get 1.5 1.10 +} -cleanup { + destroy .top.t .top +} -result HELLO +test text-25.21 {patch 1669632 (vii) - <<Undo>> shall not remove separators} -setup { + destroy .t +} -body { + text .t -undo 1 + .t insert end "This is an example text" + .t edit reset + .t insert 1.5 "WORLD " + event generate .t <Control-1> -x 1 -y 1 + .t insert insert HELLO + event generate .t <<Undo>> + .t insert insert E + event generate .t <<Undo>> + .t get 1.0 "1.0 lineend" +} -cleanup { + destroy .t +} -result "This WORLD is an example text" +test text-25.22 {patch 1669632 (v) - <<Clear>> is atomic} -setup { + destroy .t +} -body { + toplevel .top + pack [text .top.t -undo 1] + .top.t insert end "This is an example text" + .top.t edit reset + .top.t mark set insert 1.5 + .top.t insert 1.5 "A" + update + focus -force .top.t + event generate .top.t <Delete> + event generate .top.t <<SelectNextChar>> + event generate .top.t <<Clear>> + event generate .top.t <Delete> + event generate .top.t <<Undo>> + .top.t get 1.0 "1.0 lineend" +} -cleanup { + destroy .top.t .top +} -result "This A an example text" + test text-25.23 {patch 1669632 (v) - <<Cut>> is atomic} -setup { + destroy .t +} -body { + toplevel .top + pack [text .top.t -undo 1] + .top.t insert end "This is an example text" + .top.t edit reset + .top.t mark set insert 1.5 + .top.t insert 1.5 "A" + update + focus -force .top.t + event generate .top.t <Delete> + event generate .top.t <<SelectNextChar>> + event generate .top.t <<Cut>> + event generate .top.t <Delete> + event generate .top.t <<Undo>> + .top.t get 1.0 "1.0 lineend" +} -cleanup { + destroy .top.t .top +} -result "This A an example text" test text-28.1 {bug fix - 624372, ControlUtfProc long lines} -body { pack [text .t -wrap none] @@ -6536,7 +6880,7 @@ test text-33.2 {TextWidgetCmd procedure, "peer" option} -setup { test text-33.3 {TextWidgetCmd procedure, "peer" option} -setup { text .t } -body { - .t p names + .t pee names } -cleanup { destroy .t } -returnCodes {ok} -result {} diff --git a/tests/textBTree.test b/tests/textBTree.test index 41b3d98..ebd6c50 100644 --- a/tests/textBTree.test +++ b/tests/textBTree.test @@ -872,7 +872,21 @@ test btree-14.1 {check tag presence} -setup { } -cleanup { destroy .t } -result {x y z} - +test btree-14.2 {TkTextIsElided} -setup { + destroy .t + text .t +} -body { + .t delete 1.0 end + .t tag config hidden -elide 1 + .t insert end "Line1\nLine2\nLine3\n" + .t tag add hidden 2.0 3.0 + .t tag add sel 1.2 3.2 + # next line used to panic because of "Bad tag priority being toggled on" + # (see bug [382da038c9]) + .t index "2.0 - 1 display line linestart" +} -cleanup { + destroy .t +} -result {1.0} test btree-15.1 {rebalance with empty node} -setup { destroy .t diff --git a/tests/textDisp.test b/tests/textDisp.test index 8e99eff..353999f 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -27,9 +27,10 @@ proc scrollError args { # 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 +set twbw 2 +set twht 2 +option add *Text.borderWidth $twbw +option add *Text.highlightThickness $twht # The frame .f is needed to make sure that the overall window is always # fairly wide, even if the text window is very narrow. This is needed @@ -536,20 +537,24 @@ test textDisp-4.1 {UpdateDisplayInfo, basic} {textfonts} { .t insert end "Line 1\nLine 2\nLine 3\n" update .t delete 2.0 2.end + update + set res $tk_textRelayout .t insert 2.0 "New Line 2" update - list [.t bbox 1.0] [.t bbox 2.0] [.t bbox 3.0] $tk_textRelayout -} [list [list 5 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] 2.0] + lappend res [.t bbox 1.0] [.t bbox 2.0] [.t bbox 3.0] $tk_textRelayout +} [list 2.0 [list 5 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] 2.0] test textDisp-4.2 {UpdateDisplayInfo, re-use tail of text line} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update .t mark set x 2.21 .t delete 2.2 + update + set res $tk_textRelayout .t insert 2.0 X update - list [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout -} [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 12 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}] + lappend res [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout +} [list 2.0 2.20 [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 12 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}] test textDisp-4.3 {UpdateDisplayInfo, tail of text line shifts} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" @@ -610,6 +615,10 @@ catch {destroy .f2} .t configure -borderwidth 0 -wrap char wm geom . {} update +set bw [.t cget -borderwidth] +set px [.t cget -padx] +set py [.t cget -pady] +set hlth [.t cget -highlightthickness] test textDisp-4.7 {UpdateDisplayInfo, filling in extra vertical space} { # This test was failing on Windows because the title bar on . # was a certain minimum size and it was interfering with the size @@ -648,7 +657,7 @@ test textDisp-4.9 {UpdateDisplayInfo, filling in extra vertical space} {textfont update .t delete 15.0 end list [.t bbox 7.0] [.t bbox 12.0] -} [list [list 3 [expr {2*$fixedDiff + 29}] 7 $fixedHeight] [list 3 [expr {7*$fixedDiff + 94}] 7 $fixedHeight]] +} [list [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + $fixedHeight}] $fixedWidth $fixedHeight] [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + 6 * $fixedHeight}] $fixedWidth $fixedHeight]] test textDisp-4.10 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" @@ -657,7 +666,7 @@ test textDisp-4.10 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 13.0 end update list [.t index @0,0] $tk_textRelayout $tk_textRedraw -} {5.0 {12.0 7.0 6.40 6.20 6.0 5.0} {5.0 6.0 6.20 6.40 7.0 12.0}} +} {6.0 {13.0 7.0 6.40 6.20 6.0} {6.0 6.20 6.40 7.0 13.0}} test textDisp-4.11 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around, not once but really quite a few times.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" @@ -666,7 +675,7 @@ test textDisp-4.11 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 14.0 end update list [.t index @0,0] $tk_textRelayout $tk_textRedraw -} {6.40 {13.0 7.0 6.80 6.60 6.40} {6.40 6.60 6.80 7.0 13.0}} +} {6.60 {14.0 7.0 6.80 6.60} {6.60 6.80 7.0 14.0}} test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16" @@ -1147,6 +1156,40 @@ test textDisp-8.11 {TkTextChanged, scrollbar notification when changes are off-s .t configure -yscrollcommand "" set scrollInfo } {0.0 0.625} +test textDisp-8.12 {TkTextChanged, moving the insert cursor redraws only past and new lines} { + .t delete 1.0 end + .t configure -wrap none + for {set i 1} {$i < 25} {incr i} { + .t insert end "Line $i Line $i\n" + } + .t tag add hidden 5.0 8.0 + .t tag configure hidden -elide true + .t mark set insert 9.0 + update + .t mark set insert 8.0 ; # up one line + update + set res [list $tk_textRedraw] + .t mark set insert 12.2 ; # in the visible text + update + lappend res $tk_textRedraw + .t mark set insert 6.5 ; # in the hidden text + update + lappend res $tk_textRedraw + .t mark set insert 3.5 ; # in the visible text again + update + lappend res $tk_textRedraw + .t mark set insert 3.8 ; # within the same line + update + lappend res $tk_textRedraw +} {{8.0 9.0} {8.0 12.0} {8.0 12.0} {3.0 8.0} {3.0 4.0}} +test textDisp-8.13 {TkTextChanged, used to crash, see [06c1433906]} { + .t delete 1.0 end + .t insert 1.0 \nLine2\nLine3\n + update + .t insert 3.0 "" + .t delete 1.0 2.0 + update idletasks +} {} test textDisp-9.1 {TkTextRedrawTag} { .t configure -wrap char @@ -1172,40 +1215,44 @@ test textDisp-9.3 {TkTextRedrawTag} { .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" update .t tag add big 2.2 2.4 + update .t tag remove big 1.0 end update list $tk_textRelayout $tk_textRedraw -} {2.0 2.0} +} {{2.0 2.20} {2.0 2.20 eof}} test textDisp-9.4 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" update .t tag add big 2.2 2.20 + update .t tag remove big 1.0 end update list $tk_textRelayout $tk_textRedraw -} {2.0 2.0} +} {{2.0 2.20} {2.0 2.20 eof}} test textDisp-9.5 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" update .t tag add big 2.2 2.end + update .t tag remove big 1.0 end update list $tk_textRelayout $tk_textRedraw -} {{2.0 2.20} {2.0 2.20}} +} {{2.0 2.20} {2.0 2.20 eof}} test textDisp-9.6 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end - .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" + .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap" update .t tag add big 2.2 3.5 + update .t tag remove big 1.0 end update list $tk_textRelayout $tk_textRedraw -} {{2.0 2.20 3.0} {2.0 2.20 3.0}} +} {{2.0 2.20 3.0 3.20} {2.0 2.20 3.0 3.20 eof}} test textDisp-9.7 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end @@ -1257,6 +1304,58 @@ test textDisp-9.11 {TkTextRedrawTag} { update set tk_textRedraw } {} +test textDisp-9.12 {TkTextRedrawTag} { + .t configure -wrap char + .t delete 1.0 end + for {set i 1} {$i < 5} {incr i} { + .t insert end "Line $i+++Line $i\n" + } + .t tag configure hidden -elide true + .t tag add hidden 2.6 3.6 + update + .t tag add hidden 3.11 4.6 + update + list $tk_textRelayout $tk_textRedraw +} {2.0 {2.0 eof}} +test textDisp-9.13 {TkTextRedrawTag} { + .t configure -wrap none + .t delete 1.0 end + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i - This is Line [format %c [expr 64+$i]]\n" + } + .t tag add hidden 2.8 2.17 + .t tag add hidden 6.8 7.17 + .t tag configure hidden -background red + .t tag configure hidden -elide true + update + .t tag configure hidden -elide false + update + list $tk_textRelayout $tk_textRedraw +} {{2.0 6.0 7.0} {2.0 6.0 7.0}} +test textDisp-9.14 {TkTextRedrawTag} { + pack [text .tnocrash] + for {set i 1} {$i < 6} {incr i} { + .tnocrash insert end \nfoo$i + } + .tnocrash tag configure mytag1 -relief raised + .tnocrash tag configure mytag2 -relief solid + update + proc doit {} { + .tnocrash tag add mytag1 4.0 5.0 + .tnocrash tag add mytag2 4.0 5.0 + after idle { + .tnocrash tag remove mytag1 1.0 end + .tnocrash tag remove mytag2 1.0 end + } + .tnocrash delete 1.0 2.0 + } + doit ; # must not crash + after 500 { + destroy .tnocrash + set done 1 + } + vwait done +} {} test textDisp-10.1 {TkTextRelayoutWindow} { .t configure -wrap char @@ -1425,7 +1524,7 @@ test textDisp-11.15 {TkTextSetYView, only a few lines visible} { update .top.t see 11.0 .top.t index @0,0 - # Thie index 9.0 should be just visible by a couple of pixels + # The index 9.0 should be just visible by a couple of pixels } {9.0} test textDisp-11.16 {TkTextSetYView, only a few lines visible} { .top.t yview 8.0 @@ -1438,9 +1537,77 @@ test textDisp-11.17 {TkTextSetYView, only a few lines visible} { update .top.t see 4.0 .top.t index @0,0 - # Thie index 2.0 should be just visible by a couple of pixels + # The index 2.0 should be just visible by a couple of pixels } {2.0} -destroy .top +test textDisp-11.18 {TkTextSetYView, see in elided lines} { + .top.t delete 1.0 end + for {set i 1} {$i < 20} {incr i} { + .top.t insert end [string repeat "Line $i" 10] + .top.t insert end "\n" + } + .top.t yview 4.0 + .top.t tag add hidden 4.10 "4.10 lineend" + .top.t tag add hidden 5.15 10.3 + .top.t tag configure hidden -elide true + update + .top.t see "8.0 lineend" + # The index "8.0 lineend" is on screen despite elided -> no scroll + .top.t index @0,0 +} {4.0} +test textDisp-11.19 {TkTextSetYView, see in elided lines} { + .top.t delete 1.0 end + for {set i 1} {$i < 50} {incr i} { + .top.t insert end "Line $i\n" + } + # button just for having a line with a larger height + button .top.t.b -text "Test" -bd 2 -highlightthickness 2 + .top.t window create 21.0 -window .top.t.b + .top.t tag add hidden 15.36 21.0 + .top.t tag configure hidden -elide true + .top.t configure -height 15 + wm geometry .top 300x200+0+0 + # Indices 21.0, 17.0 and 15.0 are all on the same display line + # therefore index @0,0 shall be the same for all of them + .top.t see end + update + .top.t see 21.0 + update + set ind1 [.top.t index @0,0] + .top.t see end + update + .top.t see 17.0 + update + set ind2 [.top.t index @0,0] + .top.t see end + update + .top.t see 15.0 + update + set ind3 [.top.t index @0,0] + list [expr {$ind1 == $ind2}] [expr {$ind1 == $ind3}] +} {1 1} +test textDisp-11.20 {TkTextSetYView, see in elided lines} { + .top.t delete 1.0 end + .top.t configure -wrap none + for {set i 1} {$i < 5} {incr i} { + .top.t insert end [string repeat "Line $i " 50] + .top.t insert end "\n" + } + .top.t delete 3.11 3.14 + .top.t tag add hidden 3.0 4.0 + # this shall not crash (null chunkPtr in TkTextSeeCmd is tested) + .top.t see 3.0 +} {} +test textDisp-11.21 {TkTextSetYView, window height smaller than the line height} { + .top.t delete 1.0 end + for {set i 1} {$i <= 10} {incr i} { + .top.t insert end "Line $i\n" + } + set lineheight [font metrics [.top.t cget -font] -linespace] + wm geometry .top 200x[expr {$lineheight / 2}] + update + .top.t see 1.0 + .top.t index @0,[expr {$lineheight - 2}] +} {1.0} .t configure -wrap word .t delete 50.0 51.0 @@ -1582,6 +1749,29 @@ test textDisp-13.10 {TkTextSeeCmd procedure} {} { destroy $w set res } {} +test textDisp-13.11 {TkTextSeeCmd procedure} {} { + # insertion of a character at end of a line containing multi-byte + # characters and calling see at the line end shall actually show + # this character + toplevel .top2 + pack [text .top2.t2 -wrap none] + for {set i 1} {$i < 5} {incr i} { + .top2.t2 insert end [string repeat "Line $i: éèà çù" 5]\n + + } + wm geometry .top2 300x200+0+0 + update + .top2.t2 see "1.0 lineend" + update + set ref [.top2.t2 index @0,0] + .top2.t2 insert "1.0 lineend" ç + .top2.t2 see "1.0 lineend" + update + set new [.top2.t2 index @0,0] + set res [.top2.t2 compare $ref == $new] + destroy .top2 + set res +} {0} wm geom . {} .t configure -wrap none @@ -1854,9 +2044,9 @@ test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {textfonts} { wm geometry .top1 +0+0 text .top1.t -height 3 -width 4 -wrap none -setgrid 1 -padx 6 \ -spacing3 6 - .top1.t insert end "1\n2\n3\n4\n5\n6" pack .top1.t update + .top1.t insert end "1\n2\n3\n4\n5\n6" .top1.t yview moveto 0.3333 set result [.top1.t yview] destroy .top1 @@ -2018,6 +2208,70 @@ test textDisp-16.40 {text count -xpixels} { [.t count -xpixels 1.0 "1.0 displaylineend"] \ [.t count -xpixels 1.0 end] } {35 -35 0 42 42 42 0} +test textDisp-16.41 {text count -xpixels with indices in elided lines} { + set res {} + .t delete 1.0 end + for {set i 1} {$i < 40} {incr i} { + .t insert end [string repeat "Line $i" 20] + .t insert end "\n" + } + .t configure -wrap none + .t tag add hidden 5.15 20.15 + .t tag configure hidden -elide true + lappend res [.t count -xpixels 5.15 6.0] \ + [.t count -xpixels 5.15 6.1] \ + [.t count -xpixels 6.0 6.1] \ + [.t count -xpixels 6.1 6.2] \ + [.t count -xpixels 6.1 6.0] \ + [.t count -xpixels 6.0 7.0] \ + [.t count -xpixels 6.1 7.1] \ + [.t count -xpixels 15.0 20.15] \ + [.t count -xpixels 20.15 20.16] \ + [.t count -xpixels 20.16 20.15] + .t tag remove hidden 20.0 20.15 + lappend res [expr {[.t count -xpixels 5.0 20.0] != 0}] +} [list 0 0 0 0 0 0 0 0 $fixedWidth -$fixedWidth 1] +test textDisp-16.42 {TkTextYviewCmd procedure with indices in elided lines} { + .t configure -wrap none + .t delete 1.0 end + for {set i 1} {$i < 100} {incr i} { + .t insert end [string repeat "Line $i" 20] + .t insert end "\n" + } + .t tag add hidden 5.15 20.15 + .t tag configure hidden -elide true + .t yview 35.0 + .t yview scroll [expr {- 15 * $fixedHeight}] pixels + update + .t index @0,0 +} {5.0} +test textDisp-16.43 {TkTextYviewCmd procedure with indices in elided lines} { + .t configure -wrap none + .t delete 1.0 end + for {set i 1} {$i < 100} {incr i} { + .t insert end [string repeat "Line $i" 20] + .t insert end "\n" + } + .t tag add hidden 5.15 20.15 + .t tag configure hidden -elide true + .t yview 35.0 + .t yview scroll -15 units + update + .t index @0,0 +} {5.0} +test textDisp-16.44 {TkTextYviewCmd procedure, scroll down, with elided lines} { + .t configure -wrap none + .t delete 1.0 end + foreach x [list 0 1 2 3 4 5 6 7 8 9 0] { + .t insert end "$x aaa1\n$x bbb2\n$x ccc3\n$x ddd4\n$x eee5\n$x fff6" + .t insert end "$x 1111\n$x 2222\n$x 3333\n$x 4444\n$x 5555\n$x 6666" hidden + } + .t tag configure hidden -elide true ; # 5 hidden lines + update + .t see [expr {5 + [winfo height .t] / $fixedHeight} + 1].0 + update + .t index @0,0 +} {2.0} .t delete 1.0 end foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} { @@ -2443,7 +2697,7 @@ test textDisp-19.11.23 {TextWidgetCmd procedure, "index +displaylines"} { [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \ [.t index "13.0 +2d lines"] [.t index "13.0 +3d lines"] \ [.t index "13.0 +4d lines"] -} {16.17 16.33 16.28 16.46 16.28 16.49 16.65 17.0} +} {16.17 16.33 16.28 16.46 16.28 16.49 16.65 16.72} .t tag remove elide 1.0 end test textDisp-19.11.24 {TextWidgetCmd procedure, "index +/-displaylines"} { list [.t index "11.5 + -1 display lines"] \ @@ -2552,6 +2806,63 @@ test textDisp-19.16 {count -ypixels} { [.t count -ypixels 16.0 "16.0 displaylineend +1c"] \ [.t count -ypixels "16.0 +1 displaylines" "16.0 +4 displaylines +3c"] } [list [expr {260 + 20 * $fixedDiff}] [expr {260 + 20 * $fixedDiff}] $fixedHeight [expr {2*$fixedHeight}] $fixedHeight [expr {3*$fixedHeight}]] +test textDisp-19.17 {count -ypixels with indices in elided lines} { + .t configure -wrap none + .t delete 1.0 end + for {set i 1} {$i < 100} {incr i} { + .t insert end [string repeat "Line $i" 20] + .t insert end "\n" + } + .t tag add hidden 5.15 20.15 + .t tag configure hidden -elide true + set res {} + update + lappend res \ + [.t count -ypixels 1.0 6.0] \ + [.t count -ypixels 2.0 7.5] \ + [.t count -ypixels 5.0 8.5] \ + [.t count -ypixels 6.1 6.2] \ + [.t count -ypixels 6.1 18.8] \ + [.t count -ypixels 18.0 20.50] \ + [.t count -ypixels 5.2 20.60] \ + [.t count -ypixels 20.60 20.70] \ + [.t count -ypixels 5.0 25.0] \ + [.t count -ypixels 25.0 5.0] \ + [.t count -ypixels 25.4 27.50] \ + [.t count -ypixels 35.0 38.0] + .t yview 35.0 + lappend res [.t count -ypixels 5.0 25.0] +} [list [expr {4 * $fixedHeight}] [expr {3 * $fixedHeight}] 0 0 0 0 0 0 [expr {5 * $fixedHeight}] [expr {- 5 * $fixedHeight}] [expr {2 * $fixedHeight}] [expr {3 * $fixedHeight}] [expr {5 * $fixedHeight}]] +test textDisp-19.18 {count -ypixels with indices in elided lines} { + .t configure -wrap none + .t delete 1.0 end + for {set i 1} {$i < 100} {incr i} { + .t insert end [string repeat "Line $i" 20] + .t insert end "\n" + } + .t tag add hidden 5.15 20.15 + .t tag configure hidden -elide true + .t yview 35.0 + set res {} + update + lappend res [.t count -ypixels 5.0 25.0] + .t yview scroll [expr {- 15 * $fixedHeight}] pixels + update + lappend res [.t count -ypixels 5.0 25.0] +} [list [expr {5 * $fixedHeight}] [expr {5 * $fixedHeight}]] +test textDisp-19.19 {count -ypixels with indices in elided lines} { + .t configure -wrap char + .t delete 1.0 end + for {set i 1} {$i < 25} {incr i} { + .t insert end [string repeat "Line $i -" 6] + .t insert end "\n" + } + .t tag add hidden 5.27 11.0 + .t tag configure hidden -elide true + .t yview 5.0 + update + set res [list [.t count -ypixels 5.0 11.0] [.t count -ypixels 5.0 11.20]] +} [list [expr {1 * $fixedHeight}] [expr {2 * $fixedHeight}]] .t delete 1.0 end .t insert end "Line 1" for {set i 2} {$i <= 200} {incr i} { @@ -2721,6 +3032,42 @@ test textDisp-22.9 {TkTextCharBbox, handling of spacing} {textfonts} { [.t bbox 1.1] [.t bbox 2.9] } [list [list 24 11 10 4] [list 55 [expr {$fixedDiff/2 + 15}] 10 4] [list 10 [expr {2*$fixedDiff + 43}] 10 4] [list 76 [expr {2*$fixedDiff + 40}] 10 4] [list 10 11 7 $fixedHeight] [list 69 [expr {$fixedDiff + 34}] 7 $fixedHeight]] .t tag delete spacing +test textDisp-22.10 {TkTextCharBbox, handling of elided lines} {textfonts} { + .t configure -wrap char + .t delete 1.0 end + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i - Line [format %c [expr 64+$i]]\n" + } + .t tag add hidden 2.8 2.13 + .t tag add hidden 6.8 7.13 + .t tag configure hidden -elide true + update + list \ + [expr {[lindex [.t bbox 2.9] 0] - [lindex [.t bbox 2.8] 0]}] \ + [expr {[lindex [.t bbox 2.10] 0] - [lindex [.t bbox 2.8] 0]}] \ + [expr {[lindex [.t bbox 2.13] 0] - [lindex [.t bbox 2.8] 0]}] \ + [expr {[lindex [.t bbox 6.9] 0] - [lindex [.t bbox 6.8] 0]}] \ + [expr {[lindex [.t bbox 6.10] 0] - [lindex [.t bbox 6.8] 0]}] \ + [expr {[lindex [.t bbox 6.13] 0] - [lindex [.t bbox 6.8] 0]}] \ + [expr {[lindex [.t bbox 6.14] 0] - [lindex [.t bbox 6.8] 0]}] \ + [expr {[lindex [.t bbox 6.15] 0] - [lindex [.t bbox 6.8] 0]}] \ + [expr {[lindex [.t bbox 7.0] 0] - [lindex [.t bbox 6.8] 0]}] \ + [expr {[lindex [.t bbox 7.1] 0] - [lindex [.t bbox 6.8] 0]}] \ + [expr {[lindex [.t bbox 7.12] 0] - [lindex [.t bbox 6.8] 0]}] +} [list 0 0 0 0 0 0 0 0 0 0 0] +test textDisp-22.11 {TkTextCharBbox, handling of wrapped elided lines} {textfonts} { + .t configure -wrap char + .t delete 1.0 end + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i - Line _$i - Lines .$i - Line [format %c [expr 64+$i]]\n" + } + .t tag add hidden 1.30 2.5 + .t tag configure hidden -elide true + update + list \ + [expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.4] 0]}] \ + [expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.5] 0]}] +} [list 0 0] .t delete 1.0 end .t insert end "Line 1" @@ -3350,7 +3697,7 @@ test textDisp-28.1 {"yview" option with bizarre scroll command} { set result [.t2.t index @0,0] update lappend result [.t2.t index @0,0] -} {6.0 1.0} +} {6.0 2.0} test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} @@ -3366,7 +3713,7 @@ test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {textfonts .t2.t window create 1.1 -window .t2.t.f update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] -} [list [list 0.0 [expr {14.0/30}]] 300x50+5+[expr {$fixedDiff + 18}] [list 12 [expr {$fixedDiff + 68}] 7 $fixedHeight]] +} [list [list 0.0 [expr {20.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]] test textDisp-29.2 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 @@ -3379,10 +3726,11 @@ test textDisp-29.2 {miscellaneous: lines wrap but are still too long} {textfonts .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f + update .t2.t xview scroll 1 unit update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] -} [list [list [expr {7.0/300}] 0.49] 300x50+-2+[expr {$fixedDiff + 18}] [list 5 [expr {$fixedDiff + 68}] 7 $fixedHeight]] +} [list [list [expr {1.0*$fixedWidth/300}] [expr {21.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1 - $fixedWidth}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1 - $fixedWidth}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]] test textDisp-29.2.1 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 @@ -3394,6 +3742,7 @@ test textDisp-29.2.1 {miscellaneous: lines wrap but are still too long} {textfon pack .t2.s -side bottom -fill x .t2.t insert end 1\n .t2.t insert end [string repeat "abc" 30] + update .t2.t xview scroll 5 unit update .t2.t xview @@ -3410,10 +3759,11 @@ test textDisp-29.2.2 {miscellaneous: lines wrap but are still too long} {textfon .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f + update .t2.t xview scroll 2 unit update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] -} [list [list [expr {14.0/300}] [expr {154.0/300}]] 300x50+-9+[expr {$fixedDiff + 18}] {}] +} [list [list [expr {2.0*$fixedWidth/300}] [expr {22.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1 - 2*$fixedWidth}]+[expr {$twbw + $twht + $fixedHeight + 1}] {}] test textDisp-29.2.3 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 @@ -3426,10 +3776,11 @@ test textDisp-29.2.3 {miscellaneous: lines wrap but are still too long} {textfon .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f + update .t2.t xview scroll 7 pixels update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] -} [list [list [expr {7.0/300}] 0.49] 300x50+-2+[expr {$fixedDiff + 18}] [list 5 [expr {$fixedDiff + 68}] 7 $fixedHeight]] +} [list [list [expr {7.0/300}] [expr {(20.0*$fixedWidth + 7)/300}]] 300x50+[expr {$twbw + $twht + 1 - 7}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1 - 7}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]] test textDisp-29.2.4 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 @@ -3442,10 +3793,11 @@ test textDisp-29.2.4 {miscellaneous: lines wrap but are still too long} {textfon .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f + update .t2.t xview scroll 17 pixels update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] -} [list [list [expr {17.0/300}] [expr {157.0/300}]] 300x50+-12+[expr {$fixedDiff + 18}] {}] +} [list [list [expr {17.0/300}] [expr {(20.0*$fixedWidth + 17)/300}]] 300x50+[expr {$twbw + $twht + 1 - 17}]+[expr {$twbw + $twht + $fixedHeight + 1}] {}] test textDisp-29.2.5 {miscellaneous: can show last character} { catch {destroy .t2} toplevel .t2 @@ -3786,7 +4138,7 @@ test textDisp-33.2 {one line longer than fits in the widget} { .tt debug 1 set tk_textHeightCalc "" .tt insert 1.0 [string repeat "more wrap + " 1] - after 100 ; update + after 100 ; update idletasks # Nothing should have been recalculated. set tk_textHeightCalc } {} @@ -3844,29 +4196,50 @@ test textDisp-33.5 {bold or italic fonts} win { } {italic font measurement ok} destroy .tt -test textDisp-34.1 {Text widgets multi-scrolling problem: Bug 2677890} -setup { - pack [text .t1 -width 10 -yscrollcommand {.sy set}] \ - [ttk::scrollbar .sy -orient vertical -command {.t1 yview}] \ - -side left -fill both - bindtags .sy {}; # No clicky! +test textDisp-34.1 {Line heights recalculation problem: bug 2677890} -setup { + pack [text .t1] -expand 1 -fill both set txt "" - for {set i 0} {$i < 99} {incr i} { - lappend txt "$i" [list pc $i] "\n" "" + for {set i 1} {$i < 100} {incr i} { + append txt "Line $i\n" } set result {} } -body { - .t1 insert end {*}$txt - update - lappend result [.sy get] - .t1 replace 6.0 6.0+1c "*" - lappend result [.sy get] - after 0 {lappend result [.sy get]} - after 1000 {lappend result [.sy get]} - vwait result;vwait result - return $result + .t1 insert end $txt + .t1 debug 1 + set ge [winfo geometry .] + scan $ge "%dx%d+%d+%d" width height left top + update + .t1 sync + set negative 0 + bind .t1 <<WidgetViewSync>> { if {%d < 0} {set negative 1} } + # Without the fix for bug 2677890, changing the width of the toplevel + # will launch recomputation of the line heights, but will produce negative + # number of still remaining outdated lines, which is obviously wrong. + # Thus we use this way to check for regression regarding bug 2677890, + # i.e. to check that the fix for this bug really is still in. + wm geometry . "[expr {$width * 2}]x$height+$left+$top" + update + .t1 sync + set negative +} -cleanup { + destroy .t1 +} -result {0} + +test textDisp-35.1 {Init value of charHeight - Dancing scrollbar bug 1499165} -setup { + pack [text .t1] -fill both -expand y -side left + .t insert end "[string repeat a\nb\nc\n 500000]THE END\n" + set res {} +} -body { + .t see 10000.0 + after 300 {set fr1 [.t yview] ; set done 1} + vwait done + after 300 {set fr2 [.t yview] ; set done 1} + vwait done + lappend res [expr {[lindex $fr1 0] == [lindex $fr2 0]}] + lappend res [expr {[lindex $fr1 1] == [lindex $fr2 1]}] } -cleanup { - destroy .t1 .sy -} -result {{0.0 1.0} {0.0 1.0} {0.0 1.0} {0.0 0.24}} + destroy .t1 +} -result {1 1} deleteWindows option clear diff --git a/tests/textImage.test b/tests/textImage.test index 24246cc..4bb190c 100644 --- a/tests/textImage.test +++ b/tests/textImage.test @@ -316,8 +316,7 @@ test textImage-3.1 {image change propagation} -setup { image delete vary } -result {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}} -# Fails in some environments (both in Linux and winXP) -test textImage-3.2 {delayed image management} -setup { +test textImage-3.2 {delayed image management, see also bug 1591493} -setup { destroy .t set result "" } -body { @@ -329,14 +328,16 @@ test textImage-3.2 {delayed image management} -setup { pack .t .t image create end -name test update - lappend result [.t bbox test] + foreach {x1 y1 w1 h1} [.t bbox test] {} + lappend result [list $x1 $w1 $h1] .t image configure test -image small -align top update - lappend result [.t bbox test] + foreach {x2 y2 w2 h2} [.t bbox test] {} + lappend result [list [expr {$x1==$x2}] [expr {$w2>0}] [expr {$h2>0}]] } -cleanup { destroy .t image delete small -} -result {{} {0 0 5 5}} +} -result {{0 0 0} {1 1 1}} # some temporary random tests diff --git a/tests/textIndex.test b/tests/textIndex.test index a6752cb..83a249e 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -214,9 +214,31 @@ set weirdTag "funny . +- 22.1\n\t{" set weirdMark "asdf \n{-+ 66.2\t" .t mark set $weirdMark 4.0 .t tag config y -relief raised +set weirdImage "foo-1" +.t image create 2.1 -image [image create photo $weirdImage] +set weirdEmbWin ".t.bar-1" +entry $weirdEmbWin +.t window create 3.1 -window $weirdEmbWin test textIndex-3.1 {TkTextGetIndex, weird mark names} { list [catch {.t index $weirdMark} msg] $msg } {0 4.0} +test textIndex-3.2 {TkTextGetIndex, weird mark names} knownBug { + list [catch {.t index "$weirdMark -1char"} msg] $msg +} {0 4.0} +test textIndex-3.3 {TkTextGetIndex, weird embedded window names} { + list [catch {.t index $weirdEmbWin} msg] $msg +} {0 3.1} +test textIndex-3.4 {TkTextGetIndex, weird embedded window names} knownBug { + list [catch {.t index "$weirdEmbWin -1char"} msg] $msg +} {0 3.0} +test textIndex-3.5 {TkTextGetIndex, weird image names} { + list [catch {.t index $weirdImage} msg] $msg +} {0 2.1} +test textIndex-3.6 {TkTextGetIndex, weird image names} knownBug { + list [catch {.t index "$weirdImage -1char"} msg] $msg +} {0 2.0} +.t delete 3.1 ; # remove the weirdEmbWin +.t delete 2.1 ; # remove the weirdImage test textIndex-4.1 {TkTextGetIndex, tags} { list [catch {.t index x.first} msg] $msg @@ -883,6 +905,21 @@ test textIndex-22.12 {text index wordstart, unicode} { test textIndex-22.13 {text index wordstart, unicode} { text_test_word wordstart "\uc700\uc700 abc" 8 } 3 +test textIndex-22.14 {text index wordstart, unicode, start index at internal segment start} { + catch {destroy .t} + text .t + .t insert end "C'est du texte en fran\u00e7ais\n" + .t insert end "\u042D\u0442\u043E\u0020\u0442\u0435\u043A\u0441\u0442\u0020\u043D\u0430\u0020\u0440\u0443\u0441\u0441\u043A\u043E\u043C" + .t mark set insert 1.23 + set res [.t index "1.23 wordstart"] + .t mark set insert 2.16 + lappend res [.t index "2.16 wordstart"] [.t index "2.15 wordstart"] +} {1.18 2.13 2.13} +test textIndex-22.15 {text index display wordstart} { + catch {destroy .t} + text .t + .t index "1.0 display wordstart" ; # used to crash +} 1.0 test textIndex-23.1 {text paragraph start} { pack [text .t2] @@ -906,6 +943,19 @@ test textIndex-24.1 {text mark prev} { set res } {1.0} +test textIndex-25.1 {IndexCountBytesOrdered, bug [3f1f79abcf]} { + pack [text .t2] + .t2 tag configure elided -elide 1 + .t2 insert end "01\n02\n03\n04\n05\n06\n07\n08\n09\n10\n" + .t2 insert end "11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n" + .t2 insert end "21\n22\n23\n25\n26\n27\n28\n29\n30\n31" + .t2 insert end "32\n33\n34\n36\n37\n38\n39" elided + # then this used to crash Tk: + .t2 see end + focus -force .t2 ; # to see the cursor blink + destroy .t2 +} {} + # cleanup rename textimage {} catch {destroy .t} diff --git a/tests/textWind.test b/tests/textWind.test index c3483e6..27b7309 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -1458,6 +1458,23 @@ test textWind-17.10 {peer widget window configuration} -setup { destroy .tt .t } -result {{-window {} {} {} {}} {-window {} {} {} {}} {-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +test textWind-18.1 {embedded window deletion triggered by a script bound to <Map>} -setup { + catch {destroy .t .f .f2} +} -body { + pack [text .t] + for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"} + .t window create end -window [frame .f -background red -width 80 -height 80] + .t window create end -window [frame .f2 -background blue -width 80 -height 80] + bind .f <Map> {.t delete .f} + update + # this shall not crash (bug 1501749) + after 100 {.t yview end} + tkwait visibility .f2 + update +} -cleanup { + destroy .t .f .f2 +} -result {} + option clear # cleanup diff --git a/tests/ttk/notebook.test b/tests/ttk/notebook.test index cdce020..3a2a6ff 100644 --- a/tests/ttk/notebook.test +++ b/tests/ttk/notebook.test @@ -468,6 +468,27 @@ test notebook-1817596-3 "insert/configure" -body { } -result [list [list .nb.l2 .nb.l0 .nb.l1] L2 L0 L1] -cleanup { destroy .nb } +test notebook-readd-1 "add same widget twice" -body { + pack [ttk::notebook .nb] + .nb add [ttk::button .nb.b1] -text "Button" + .nb add .nb.b1 + .nb tabs +} -result [list .nb.b1] -cleanup { destroy .nb } + +test notebook-readd-2 "add same widget twice, with options" -body { + pack [ttk::notebook .nb] + .nb add [ttk::button .nb.b1] -text "Tab label" + .nb add .nb.b1 -text "Changed tab label" + .nb tabs +} -result [list .nb.b1] -cleanup { destroy .nb } + +test notebook-readd-3 "insert same widget twice, with options" -body { + pack [ttk::notebook .nb] + .nb insert end [ttk::button .nb.b1] -text "Tab label" + .nb insert end .nb.b1 -text "Changed tab label" + .nb tabs +} -result [list .nb.b1] -cleanup { destroy .nb } + # See #1343984 test notebook-1343984-1 "don't autoselect on destroy - setup" -body { diff --git a/tests/ttk/spinbox.test b/tests/ttk/spinbox.test index 3397e37..32b77af 100644 --- a/tests/ttk/spinbox.test +++ b/tests/ttk/spinbox.test @@ -143,8 +143,8 @@ test spinbox-1.8.4 "-validate option: " -setup { .sb configure -validate all -validatecommand {lappend ::spinbox_test %P} pack .sb .sb set 50 - focus .sb - after 100 {set ::spinbox_wait 1} ; vwait ::spinbox_wait + focus -force .sb + after 500 {set ::spinbox_wait 1} ; vwait ::spinbox_wait set ::spinbox_test } -cleanup { destroy .sb diff --git a/tests/winButton.test b/tests/winButton.test index 8bf1d01..88b4345 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -22,8 +22,10 @@ option clear # ---------------------------------------------------------------------- test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { - testImageType win + testImageType win nonPortable } -setup { + # nonPortable because of [3e3e25f483]: on Win7 first started with a high DPI screen + # the smallest size (i.e. 8) is not available for "MS Sans Serif" font deleteWindows } -body { image create test image1 @@ -47,7 +49,11 @@ test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { image delete image1 } -result {68 48 70 50 90 52 90 52} -test winbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints win -setup { +test winbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { + # nonPortable because of [3e3e25f483]: on Win7 first started with a high DPI screen + # the smallest size (i.e. 8) is not available for "MS Sans Serif" font deleteWindows } -body { label .b1 -bitmap question -bd 3 -padx 0 -pady 2 diff --git a/tests/winDialog.test b/tests/winDialog.test index c092e76..c8c36bf 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -22,9 +22,26 @@ testConstraint english [expr { && (([testwinlocale] & 0xff) == 9) }] +proc vista? {{prevista 0} {postvista 1}} { + lassign [split $::tcl_platform(osVersion) .] major + return [expr {$major >= 6 ? $postvista : $prevista}] +} + +# What directory to use in initialdir tests. Old code used to use +# c:/. However, on Vista/later that is a protected directory if you +# are not running privileged. Moreover, not everyone has a drive c: +# but not having a TEMP would break a lot Windows programs +proc initialdir {} { + # file join to return in Tcl canonical format (/ separator, not \) + #return [file join $::env(TEMP)] + return [tcltest::temporaryDirectory] +} + + proc start {arg} { set ::tk_dialog 0 set ::iter_after 0 + set ::dialogclass "#32770" after 1 $arg } @@ -34,19 +51,35 @@ proc then {cmd} { set ::dialogresult {} set ::testfont {} - afterbody + # Do not make the delay too short. The newer Vista dialogs take + # time to come up. Even if the testforwindow returns true, the + # controls are not ready to accept messages + after 500 afterbody vwait ::dialogresult return $::dialogresult } proc afterbody {} { - if {$::tk_dialog == 0} { - if {[incr ::iter_after] > 30} { - set ::dialogresult ">30 iterations waiting on tk_dialog" + # On Vista and later, using the new file dialogs we have to find + # the window using its title as tk_dialog will not be set at the C level + if {[vista?]} { + if {[catch {testfindwindow "" $::dialogclass} ::tk_dialog]} { + if {[incr ::iter_after] > 30} { + set ::dialogresult ">30 iterations waiting on tk_dialog" + return + } + after 150 {afterbody} + return + } + } else { + if {$::tk_dialog == 0} { + if {[incr ::iter_after] > 30} { + set ::dialogresult ">30 iterations waiting on tk_dialog" + return + } + after 150 {afterbody} return } - after 150 {afterbody} - return } uplevel #0 {set dialogresult [eval $command]} } @@ -205,7 +238,7 @@ test winDialog-5.2 {GetFileName: one argument} -constraints { test winDialog-5.3 {GetFileName: many arguments} -constraints { nt testwinevent } -body { - start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo} + start {tk_getOpenFile -initialdir [initialdir] -parent . -title test -initialfile foo} then { Click cancel } @@ -218,52 +251,214 @@ test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints { test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints { nt testwinevent } -body { - start {tk_getOpenFile -title bar} - then { + start {set x [tk_getOpenFile -title bar]} + set y [then { Click cancel - } + }] + # Note this also tests fix for + # http://core.tcl.tk/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6 + # $x is expected to be empty + append x $y } -result {0} test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints { nt } -body { tk_getOpenFile -initialdir bar -title } -returnCodes error -result {value for "-title" missing} + test winDialog-5.7 {GetFileName: extension begins with .} -constraints { nt testwinevent } -body { -# if (string[0] == '.') { -# string++; -# } - start {set x [tk_getSaveFile -defaultextension .foo -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.foo + +test winDialog-5.7.1 {GetFileName: extension {} } -constraints { + nt testwinevent +} -body { + start {set x [tk_getSaveFile -defaultextension {} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar + +test winDialog-5.7.2 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints { + nt testwinevent +} -body { + start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar + +test winDialog-5.7.3 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints { + nt testwinevent +} -body { + start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar.c} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.c + +test winDialog-5.7.4 {GetFileName: extension {} } -constraints { + nt testwinevent +} -body { + # Although the docs do not explicitly mention, -filetypes seems to + # override -defaultextension + start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {foo} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.c + +test winDialog-5.7.5 {GetFileName: extension {} } -constraints { + nt testwinevent +} -body { + # Although the docs do not explicitly mention, -filetypes seems to + # override -defaultextension + start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.c + + +test winDialog-5.7.6 {GetFileName: All/extension } -constraints { + nt testwinevent +} -body { + # In 8.6.4 this combination resulted in bar.ext.ext which is bad + start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {ext} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.ext + +test winDialog-5.7.7 {tk_getOpenFile: -defaultextension} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + tcltest::makeFile "" "5 7 7.ext" [initialdir] + start {set x [tk_getOpenFile \ + -defaultextension ext \ + -initialdir [file nativename [initialdir]] \ + -initialfile "5 7 7" -title Foo]} then { - SetText 0x480 bar Click ok } - string totitle $x -} -result [string totitle [file join [pwd] bar.foo]] + return $x +} -result [file join [initialdir] "5 7 7.ext"] + +test winDialog-5.7.8 {tk_getOpenFile: -defaultextension} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + tcltest::makeFile "" "5 7 8.ext" [initialdir] + start {set x [tk_getOpenFile \ + -defaultextension ext \ + -initialdir [file nativename [initialdir]] \ + -initialfile "5 7 8.ext" -title Foo]} + then { + Click ok + } + return $x +} -result [file join [initialdir] "5 7 8.ext"] + test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints { nt testwinevent } -body { start {set x [tk_getSaveFile -defaultextension foo -title Save]} + set msg {} then { - SetText 0x480 bar - Click ok + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } } - string totitle $x -} -result [string totitle [file join [pwd] bar.foo]] + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.foo test winDialog-5.9 {GetFileName: file types} -constraints { nt testwinevent } -body { -# case FILE_TYPES: - + # case FILE_TYPES: + start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} - then { - set x [GetText 0x470] - Click cancel + # XXX - currently disabled for vista style dialogs because the file + # types control has no control ID and we don't have a mechanism to + # locate it. + if {[vista?]} { + then { + Click cancel + } + return 1 + } else { + then { + set x [GetText 0x470] + Click cancel + } + return [string equal $x {foo files (*.foo)}] } - return $x -} -result {foo files (*.foo)} +} -result 1 test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints { nt } -body { @@ -271,21 +466,20 @@ test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints { tk_getSaveFile -filetypes {{"foo" .foo FOO}} } -returnCodes error -result {bad Macintosh file type "FOO"} -if {[info exists ::env(TEMP)]} { test winDialog-5.11 {GetFileName: initial directory} -constraints { nt testwinevent } -body { # case FILE_INITDIR: - + unset -nocomplain x start {set x [tk_getSaveFile \ - -initialdir [file normalize $::env(TEMP)] \ + -initialdir [initialdir] \ -initialfile "12x 455" -title Foo]} then { Click ok } return $x -} -result [file join [file normalize $::env(TEMP)] "12x 455"] -} +} -result [file join [initialdir] "12x 455"] + test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -constraints { nt } -body { @@ -293,6 +487,199 @@ test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -c tk_getOpenFile -initialdir ~12x/455 } -returnCodes error -result {user "12x" doesn't exist} + +test winDialog-5.12.1 {tk_getSaveFile: initial directory: ~} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir ~ \ + -initialfile "5 12 1" -title Foo]} + then { + Click ok + } + return $x +} -result [file normalize [file join ~ "5 12 1"]] + +test winDialog-5.12.2 {tk_getSaveFile: initial directory: ~user} -constraints { + nt testwinevent +} -body { + + # Note: this test will fail on Tcl versions 8.6.4 and earlier due + # to a bug in file normalize for names of the form ~xxx that + # returns the wrong dir on Windows. In particular (in Win8 at + # least) it returned /users/Default instead of /users/USERNAME... + + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir ~$::tcl_platform(user) \ + -initialfile "5 12 2" -title Foo]} + then { + Click ok + } + return $x +} -result [file normalize [file join ~$::tcl_platform(user) "5 12 2"]] + +test winDialog-5.12.3 {tk_getSaveFile: initial directory: .} -constraints { + nt testwinevent +} -body { + # Windows remembers dirs from previous selections so use + # a subdir for this test, not [initialdir] itself + set newdir [tcltest::makeDirectory "5 12 3"] + set cur [pwd] + try { + cd $newdir + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir . \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + } finally { + cd $cur + } + string equal $x [file join $newdir testfile] +} -result 1 + +test winDialog-5.12.4 {tk_getSaveFile: initial directory: unicode} -constraints { + nt testwinevent +} -body { + set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"] + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir $dir \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + string equal $x [file join $dir testfile] +} -result 1 + +test winDialog-5.12.5 {tk_getSaveFile: initial directory: nativename} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir [file nativename [initialdir]] \ + -initialfile "5 12 5" -title Foo]} + then { + Click ok + } + return $x +} -result [file join [initialdir] "5 12 5"] + +test winDialog-5.12.6 {tk_getSaveFile: initial directory: relative} -constraints { + nt testwinevent +} -body { + # Windows remembers dirs from previous selections so use + # a subdir for this test, not [initialdir] itself + set dir [tcltest::makeDirectory "5 12 6"] + set cur [pwd] + try { + cd [file dirname $dir] + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir "5 12 6" \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + } finally { + cd $cur + } + string equal $x [file join $dir testfile] +} -result 1 + +test winDialog-5.12.7 {tk_getOpenFile: initial directory: ~} -constraints { + nt testwinevent +} -body { + set fn [file tail [lindex [glob -types f ~/*] 0]] + unset -nocomplain x + start {set x [tk_getOpenFile \ + -initialdir ~ \ + -initialfile $fn -title Foo]} + then { + Click ok + } + string equal $x [file normalize [file join ~ $fn]] +} -result 1 + +test winDialog-5.12.8 {tk_getOpenFile: initial directory: .} -constraints { + nt testwinevent +} -body { + # Windows remembers dirs from previous selections so use + # a subdir for this test, not [initialdir] itself + set newdir [tcltest::makeDirectory "5 12 8"] + set path [tcltest::makeFile "" "testfile" $newdir] + set cur [pwd] + try { + cd $newdir + unset -nocomplain x + start {set x [tk_getOpenFile \ + -initialdir . \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + } finally { + cd $cur + } + string equal $x $path +} -result 1 + +test winDialog-5.12.9 {tk_getOpenFile: initial directory: unicode} -constraints { + nt testwinevent +} -body { + set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"] + set path [tcltest::makeFile "" testfile $dir] + unset -nocomplain x + start {set x [tk_getOpenFile \ + -initialdir $dir \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + string equal $x $path +} -result 1 + +test winDialog-5.12.10 {tk_getOpenFile: initial directory: nativename} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + tcltest::makeFile "" "5 12 10" [initialdir] + start {set x [tk_getOpenFile \ + -initialdir [file nativename [initialdir]] \ + -initialfile "5 12 10" -title Foo]} + then { + Click ok + } + return $x +} -result [file join [initialdir] "5 12 10"] + +test winDialog-5.12.11 {tk_getOpenFile: initial directory: relative} -constraints { + nt testwinevent +} -body { + # Windows remembers dirs from previous selections so use + # a subdir for this test, not [initialdir] itself + set dir [tcltest::makeDirectory "5 12 11"] + set path [tcltest::makeFile "" testfile $dir] + set cur [pwd] + try { + cd [file dirname $dir] + unset -nocomplain x + start {set x [tk_getOpenFile \ + -initialdir [file tail $dir] \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + } finally { + cd $cur + } + string equal $x $path +} -result 1 + test winDialog-5.13 {GetFileName: initial file} -constraints { nt testwinevent } -body { @@ -302,27 +689,31 @@ test winDialog-5.13 {GetFileName: initial file} -constraints { then { Click ok } - string totitle $x -} -result [string totitle [file join [pwd] "12x 456"]] + file tail $x +} -result "12x 456" test winDialog-5.14 {GetFileName: initial file: Tcl_TranslateFileName()} -constraints { nt } -body { # if (Tcl_TranslateFileName(interp, string, &ds) == NULL) tk_getOpenFile -initialfile ~12x/455 } -returnCodes error -result {user "12x" doesn't exist} -test winDialog-5.15 {GetFileName: initial file: long name} -constraints { - nt testwinevent -} -body { - start { - set dialogresult [catch { - tk_getSaveFile -initialfile [string repeat a 1024] -title Long - } x] - } - then { - Click ok - } - list $dialogresult [string match "invalid filename *" $x] -} -result {1 1} +if {![vista?]} { + # XXX - disabled for Vista because the new dialogs allow long file + # names to be specified but force the user to change it. + test winDialog-5.15 {GetFileName: initial file: long name} -constraints { + nt testwinevent + } -body { + start { + set dialogresult [catch { + tk_getSaveFile -initialfile [string repeat a 1024] -title Long + } x] + } + then { + Click ok + } + list $dialogresult [string match "invalid filename *" $x] + } -result {1 1} +} test winDialog-5.16 {GetFileName: parent} -constraints { nt } -body { @@ -346,18 +737,34 @@ test winDialog-5.17 {GetFileName: title} -constraints { Click cancel } } -result {0} -test winDialog-5.18 {GetFileName: no filter specified} -constraints { - nt testwinevent -} -body { -# if (ofn.lpstrFilter == NULL) +if {[vista?]} { + # In the newer file dialogs, the file type widget does not even exist + # if no file types specified + test winDialog-5.18 {GetFileName: no filter specified} -constraints { + nt testwinevent + } -body { + # if (ofn.lpstrFilter == NULL) + start {tk_getOpenFile -title Filter} + then { + catch {set x [GetText 0x470]} y + Click cancel + } + return $y + } -result {Could not find control with id 1136} +} else { + test winDialog-5.18 {GetFileName: no filter specified} -constraints { + nt testwinevent + } -body { + # if (ofn.lpstrFilter == NULL) - start {tk_getOpenFile -title Filter} - then { - set x [GetText 0x470] - Click cancel - } - return $x -} -result {All Files (*.*)} + start {tk_getOpenFile -title Filter} + then { + set x [GetText 0x470] + Click cancel + } + return $x + } -result {All Files (*.*)} +} test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints { nt } -setup { @@ -407,19 +814,23 @@ test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints { } return $x } -result {&Save} -if {[info exists ::env(TEMP)]} { test winDialog-5.23 {GetFileName: convert \ to /} -constraints { nt testwinevent } -body { + set msg {} start {set x [tk_getSaveFile -title Back]} then { - SetText 0x480 [file nativename \ - [file join [file normalize $::env(TEMP)] "12x 457"]] - Click ok + if {[catch {SetText [vista? 0x47C 0x3e9] [file nativename \ + [file join [initialdir] "12x 457"]]} msg]} { + Click cancel + } else { + Click ok + } } - return $x -} -result [file join [file normalize $::env(TEMP)] "12x 457"] -} + return $x$msg +} -cleanup { + unset msg +} -result [file join [initialdir] "12x 457"] test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints { nt } -body { @@ -460,10 +871,12 @@ test winDialog-8.1 {OFNHookProc} -constraints {emptyTest nt} -body {} test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints { nt testwinevent } -body { - start {tk_chooseDirectory} - then { + start {set x [tk_chooseDirectory]} + set y [then { Click cancel - } + }] + # $x should be "" on a Cancel + append x $y } -result {0} test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints { nt @@ -474,7 +887,7 @@ test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints { nt testwinevent } -body { start { - tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test + tk_chooseDirectory -initialdir [initialdir] -mustexist 1 -parent . -title test } then { Click cancel @@ -503,12 +916,12 @@ test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints { } -body { # case DIR_INITIAL: - start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]} + start {set x [tk_chooseDirectory -initialdir [initialdir] -title Foo]} then { Click ok } string tolower [set x] -} -result {c:/} +} -result [string tolower [initialdir]] test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} -constraints { nt } -body { diff --git a/tests/window.test b/tests/window.test index 876ba81..fea695a 100644 --- a/tests/window.test +++ b/tests/window.test @@ -9,9 +9,6 @@ package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -testConstraint unthreaded [expr { - (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded)) -}] namespace import ::tk::test::loadTkCommand update @@ -192,9 +189,8 @@ test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} -constrain list $error $msg } -result {0 {}} -# window-2.9 deadlocks threaded Tk [Bug 1715716] test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} -constraints { - unixOrWin unthreaded + unixOrWin } -body { set code [loadTkCommand] append code { |