diff options
author | fvogel <fvogelnew1@free.fr> | 2016-01-11 13:23:20 (GMT) |
---|---|---|
committer | fvogel <fvogelnew1@free.fr> | 2016-01-11 13:23:20 (GMT) |
commit | 37190756fab88abf9029f6e1c4ef1c2cf383de21 (patch) | |
tree | 87dfd77a94fb45488edde792e3b0735459a1fea7 /tests | |
parent | d25597c12ab6684b16f3bd59198e771a1c570d03 (diff) | |
parent | d18cae5af3758008a7cf2a01fef2dc26c5636d9c (diff) | |
download | tk-37190756fab88abf9029f6e1c4ef1c2cf383de21.zip tk-37190756fab88abf9029f6e1c4ef1c2cf383de21.tar.gz tk-37190756fab88abf9029f6e1c4ef1c2cf383de21.tar.bz2 |
merged trunk
Diffstat (limited to 'tests')
-rw-r--r-- | tests/bevel.tcl | 39 | ||||
-rw-r--r-- | tests/bind.test | 43 | ||||
-rw-r--r-- | tests/bugs.tcl | 2 | ||||
-rw-r--r-- | tests/butGeom2.tcl | 2 | ||||
-rw-r--r-- | tests/canvPsGrph.tcl | 6 | ||||
-rw-r--r-- | tests/canvPsImg.tcl | 2 | ||||
-rw-r--r-- | tests/canvText.test | 5 | ||||
-rw-r--r-- | tests/constraints.tcl | 7 | ||||
-rw-r--r-- | tests/entry.test | 51 | ||||
-rw-r--r-- | tests/event.test | 6 | ||||
-rw-r--r-- | tests/font.test | 93 | ||||
-rw-r--r-- | tests/listbox.test | 39 | ||||
-rw-r--r-- | tests/menu.test | 21 | ||||
-rwxr-xr-x | tests/option.file3 | 18 | ||||
-rw-r--r-- | tests/option.test | 12 | ||||
-rw-r--r-- | tests/panedwindow.test | 116 | ||||
-rw-r--r-- | tests/scale.test | 39 | ||||
-rw-r--r-- | tests/scrollbar.test | 32 | ||||
-rw-r--r-- | tests/send.test | 2 | ||||
-rw-r--r-- | tests/spinbox.test | 26 | ||||
-rw-r--r-- | tests/text.test | 178 | ||||
-rw-r--r-- | tests/textBTree.test | 16 | ||||
-rw-r--r-- | tests/textDisp.test | 425 | ||||
-rw-r--r-- | tests/textImage.test | 11 | ||||
-rw-r--r-- | tests/textIndex.test | 28 | ||||
-rw-r--r-- | tests/textWind.test | 17 | ||||
-rw-r--r-- | tests/ttk/spinbox.test | 4 | ||||
-rw-r--r-- | tests/winButton.test | 10 | ||||
-rw-r--r-- | tests/winDialog.test | 533 |
29 files changed, 1560 insertions, 223 deletions
diff --git a/tests/bevel.tcl b/tests/bevel.tcl index 950b714..531def0 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,35 @@ 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/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/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/entry.test b/tests/entry.test index 11408ac..9c30b00 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 $fixed -bd 2 -relief raised -width 20 + pack .e +} -body { + .e insert end "012\t456\t" + update + list [.e index @81] [.e index @82] [.e index @116] [.e index @117] +} -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 a07e391..9e44a93 100644 --- a/tests/font.test +++ b/tests/font.test @@ -12,7 +12,25 @@ 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 @@ -161,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 @@ -192,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 @@ -229,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} @@ -238,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 @@ -258,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++) @@ -267,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 @@ -283,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} @@ -434,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 {} @@ -464,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} @@ -509,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} @@ -646,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 { @@ -752,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 { @@ -760,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 @@ -1509,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 { diff --git a/tests/listbox.test b/tests/listbox.test index 72b1cdf..0519e93 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -3068,6 +3068,45 @@ test listbox-30.1 {Bug 3607326} -setup { 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.file3 b/tests/option.file3 new file mode 100755 index 0000000..87f41ae --- /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 23866d7..ea5b5d1 100644 --- a/tests/option.test +++ b/tests/option.test @@ -399,18 +399,20 @@ 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..7ade29a 100644 --- a/tests/text.test +++ b/tests/text.test @@ -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 count -update -ypixels 1.0 end + 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 { @@ -3440,9 +3503,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 +5562,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 +6198,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] 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..ac3aee0 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,41 @@ 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 + # This last one is tricky: correct result really is {2.0 3.0} when + # calling .t mark set insert, two calls to TkTextChanged are done: + # (a) to redraw the line of the past position of the cursor + # (b) to redraw the line of the new position of the cursor + # During (a) the display line showing the cursor gets unlinked, + # which leads TkTextChanged in (b) to schedule a redraw starting + # one line _before_ the line containing the insert cursor. This is + # because during (b) findDLine cannot return the display line the + # cursor is in since this display line was just unlinked in (a). +} {{8.0 9.0} {8.0 12.0} {8.0 12.0} {3.0 8.0} {2.0 3.0}} test textDisp-9.1 {TkTextRedrawTag} { .t configure -wrap char @@ -1172,40 +1216,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 +1305,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 +1525,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 +1538,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 +1750,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 +2045,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 +2209,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 +2698,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 +2807,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 +3033,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 +3698,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 +3714,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 +3727,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 +3743,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 +3760,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 +3777,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 +3794,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 +4139,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 } {} @@ -3866,7 +4219,23 @@ test textDisp-34.1 {Text widgets multi-scrolling problem: Bug 2677890} -setup { return $result } -cleanup { destroy .t1 .sy -} -result {{0.0 1.0} {0.0 1.0} {0.0 1.0} {0.0 0.24}} +} -result {{0.0 0.24} {0.0 0.24} {0.0 0.24} {0.0 0.24}} + +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 +} -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 c949b1f..83a249e 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -905,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] @@ -928,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/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 8aa9ac3..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,64 +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 0x47C bar} msg]} { + 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 } } - string totitle $x$msg + set x "[file tail $x]$msg" } -cleanup { unset msg -} -result [string totitle [file join [pwd] bar.foo]] +} -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 { + Click ok + } + 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 { - if {[catch {SetText 0x47C bar} msg]} { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } - string totitle $x$msg + set x "[file tail $x]$msg" } -cleanup { unset msg -} -result [string totitle [file join [pwd] bar.foo]] +} -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 { @@ -283,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 { @@ -305,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 { @@ -314,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 { @@ -358,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 { @@ -419,15 +814,14 @@ 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 { - if {[catch {SetText 0x47C [file nativename \ - [file join [file normalize $::env(TEMP)] "12x 457"]]} msg]} { + if {[catch {SetText [vista? 0x47C 0x3e9] [file nativename \ + [file join [initialdir] "12x 457"]]} msg]} { Click cancel } else { Click ok @@ -436,8 +830,7 @@ test winDialog-5.23 {GetFileName: convert \ to /} -constraints { return $x$msg } -cleanup { unset msg -} -result [file join [file normalize $::env(TEMP)] "12x 457"] -} +} -result [file join [initialdir] "12x 457"] test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints { nt } -body { @@ -478,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 @@ -492,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 @@ -521,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 { |