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.

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) <<TkFontchooserFontChanged>>
     }
+    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