From c550110fea03fbf1def408f088e37acc930c8e63 Mon Sep 17 00:00:00 2001 From: patthoyts Date: Wed, 10 Dec 2008 13:41:19 +0000 Subject: Fix some problems running the tests on windows. As Tk tests run in -singleproc 1 we cannot do the script testing without damaging the later native tests. --- library/fontchooser.tcl | 55 +++++++++++++++++++++++++++++++++++-------------- tests/fontchooser.test | 13 ++++++------ tests/winDialog.test | 12 +++++------ win/tkWinDialog.c | 3 ++- 4 files changed, 55 insertions(+), 28 deletions(-) diff --git a/library/fontchooser.tcl b/library/fontchooser.tcl index 290eebf..2998969 100644 --- a/library/fontchooser.tcl +++ b/library/fontchooser.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fontchooser.tcl,v 1.1 2008/12/10 05:02:51 das Exp $ +# RCS: @(#) $Id: fontchooser.tcl,v 1.2 2008/12/10 13:41:19 patthoyts Exp $ namespace eval ::tk::fontchooser { variable S @@ -29,8 +29,8 @@ namespace eval ::tk::fontchooser { set S(sampletext) [::msgcat::mc "AaBbYyZz01"] set S(-parent) . set S(-title) [::msgcat::mc "Font"] - set S(-font) {} - set S(-command) {} + set S(-command) "" + set S(-font) TkDefaultFont # Canonical versions of font families, styles, etc. for easier searching set S(fonts,lcase) {} @@ -74,19 +74,41 @@ proc ::tk::fontchooser::Configure {args} { variable S set specs { - {-parent "" "" .} - {-title "" "" " "} - {-font "" "" ""} + {-parent "" "" . } + {-title "" "" ""} + {-font "" "" ""} {-command "" "" ""} } - if {[llength $args] == 1 && [string equal [lindex $args 0] "-visible"]} { - return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] + if {[llength $args] == 0} { + set result {} + foreach spec $specs { + foreach {name xx yy default} $spec break + lappend result $name \ + [expr {[info exists S($name)] ? $S($name) : $default}] + } + lappend result -visible \ + [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] + return $result } - - tclParseConfigSpec [namespace which -variable S] $specs "" $args - if {$S(-parent) ne "."} { - winfo toplevel $S(-parent) + if {[llength $args] == 1} { + set option [lindex $args 0] + if {[string equal $option "-visible"]} { + return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] + } elseif {[info exists S($option)]} { + return $S($option) + } + return -code error "bad option \"$option\": must be\ + -command, -font, -parent, -title or -visible" + } + + set cache [dict create -parent $S(-parent) -title $S(-title) \ + -font $S(-font) -command $S(-command)] + set r [tclParseConfigSpec [namespace which -variable S] $specs "" $args] + if {![winfo exists $S(-parent)]} { + set err "bad window path name \"$S(-parent)\"" + array set S $cache + return -code error $err } if {[string trim $S(-title)] eq ""} { set S(-title) [::msgcat::mc "Font"] @@ -95,6 +117,7 @@ proc ::tk::fontchooser::Configure {args} { Init $S(-font) event generate $S(-parent) <> } + return $r } proc ::tk::fontchooser::Create {} { @@ -182,7 +205,9 @@ proc ::tk::fontchooser::Create {} { grid $S(W).ok -in $bbox -sticky new -pady {0 2} grid $S(W).cancel -in $bbox -sticky new -pady 2 - grid $S(W).apply -in $bbox -sticky new -pady 2 + if {$S(-command) ne ""} { + grid $S(W).apply -in $bbox -sticky new -pady 2 + } grid columnconfigure $bbox 0 -weight 1 grid $WE.strike -sticky w -padx 10 @@ -343,7 +368,7 @@ proc ::tk::fontchooser::Tracer {var1 var2 op} { $S(W).l${var}s see $n } if {!$bad} { Update } - $S(W).ok config -state $nstate + $S(W).ok configure -state $nstate } # ::tk::fontchooser::Update -- @@ -360,7 +385,7 @@ proc ::tk::fontchooser::Update {} { if {$S(strike)} { lappend S(result) overstrike} if {$S(under)} { lappend S(result) underline} - $S(sample) config -font $S(result) + $S(sample) configure -font $S(result) } # ::tk::fontchooser::Visibility -- diff --git a/tests/fontchooser.test b/tests/fontchooser.test index 0f90a46..a634300 100644 --- a/tests/fontchooser.test +++ b/tests/fontchooser.test @@ -2,7 +2,7 @@ # # Copyright (c) 2008 Pat Thoyts # -# RCS: @(#) $Id: fontchooser.test,v 1.1 2008/12/10 05:02:52 das Exp $ +# RCS: @(#) $Id: fontchooser.test,v 1.2 2008/12/10 13:41:19 patthoyts Exp $ # package require tcltest 2.1 @@ -89,11 +89,12 @@ test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body { } -match glob -result {*} # ------------------------------------------------------------------------- -# By explicitly calling the tk internal command we always test the script -# implementation here even when the current platform defines a native -# font dialog. This is intentional in this test file. - -source [file join $tk_library fontchooser.tcl] +# +# The remaining tests in this file are only relevant for the script +# implementation. They can be tested by sourcing the script file but +# the Tk tests are run with -singleproc 1 and doing this affects the +# result of later attempts to test the native implementations. +# testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]] test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body { diff --git a/tests/winDialog.test b/tests/winDialog.test index 3a5c347..f176e92 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 1998-1999 ActiveState Corporation. # -# RCS: @(#) $Id: winDialog.test,v 1.24 2008/12/10 05:02:52 das Exp $ +# RCS: @(#) $Id: winDialog.test,v 1.25 2008/12/10 13:41:19 patthoyts Exp $ package require tcltest 2.2 namespace import ::tcltest::* @@ -43,13 +43,13 @@ proc then {cmd} { proc afterbody {} { if {$::tk_dialog == 0} { - if {[incr ::iter_after] > 30} { - set ::dialogresult ">30 iterations waiting on tk_dialog" + 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]} } diff --git a/win/tkWinDialog.c b/win/tkWinDialog.c index 1616a97..fd77b10 100644 --- a/win/tkWinDialog.c +++ b/win/tkWinDialog.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkWinDialog.c,v 1.57 2008/12/10 09:08:29 patthoyts Exp $ + * RCS: @(#) $Id: tkWinDialog.c,v 1.58 2008/12/10 13:41:19 patthoyts Exp $ * */ @@ -2822,6 +2822,7 @@ const TkEnsemble tkFontchooserEnsemble[] = { { "configure", FontchooserConfigureCmd, NULL }, { "show", FontchooserShowCmd, NULL }, { "hide", FontchooserHideCmd, NULL }, + { NULL, NULL, NULL } }; int -- cgit v0.12