TIP #324 IMPLEMENTATION

2 files changed, 321 insertions, 1 deletions

diff --git a/tests/fontchooser.test b/tests/fontchooser.test
new file mode 100644
index 0000000..0f90a46
--- /dev/null
+++ b/tests/fontchooser.test
@@ -0,0 +1,203 @@
+# Test the "tk::fontchooser" command
+#
+# Copyright (c) 2008 Pat Thoyts
+#
+# RCS: @(#) $Id: fontchooser.test,v 1.1 2008/12/10 05:02:52 das Exp $
+#
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# the following helper functions are related to the functions used
+# in winDialog.test where they are used to send messages to the win32
+# dialog (hence the wierdness).
+
+proc start {cmd} {
+    set ::tk_dialog {}
+    set ::iter_after 0
+    after 1 $cmd
+}
+proc then {cmd} {
+    set ::command $cmd
+    set ::dialogresult {}
+    set ::testfont {}
+    afterbody
+    vwait ::dialogresult
+    return $::dialogresult
+}
+proc afterbody {} {
+    if {$::tk_dialog == {}} {
+        if {[incr ::iter_after] > 30} {
+            set ::dialogresult ">30 iterations waiting for tk_dialog"
+            return
+        }
+        after 150 {afterbody}
+        return
+    }
+    uplevel #0 {set dialogresult [eval $command]}
+}
+proc Click {button} {
+    switch -exact -- $button {
+        ok { $::tk_dialog.ok invoke }
+        cancel { $::tk_dialog.cancel invoke }
+        apply { $::tk_dialog.apply invoke }
+        default { return -code error "invalid button name \"$button\"" }
+    }
+}
+proc ApplyFont {font} {
+#    puts stderr "apply: $font"
+    set ::testfont $font
+}
+
+# -------------------------------------------------------------------------
+
+test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body {
+    tk fontchooser -z
+} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show}
+
+test fontchooser-1.2 {tk fontchooser: usage} -returnCodes error -body {
+    tk fontchooser configure -z
+} -match glob -result {bad option "-z":*}
+
+test fontchooser-1.3 {tk fontchooser: usage} -returnCodes error -body {
+    tk fontchooser configure -parent . -font
+} -result {value for "-font" missing}
+
+test fontchooser-1.4 {tk fontchooser: usage} -returnCodes error -body {
+    tk fontchooser configure -parent . -title
+} -result {value for "-title" missing}
+
+test fontchooser-1.5 {tk fontchooser: usage} -returnCodes error -body {
+    tk fontchooser configure -parent . -command
+} -result {value for "-command" missing}
+
+test fontchooser-1.6 {tk fontchooser: usage} -returnCodes error -body {
+    tk fontchooser configure -title . -parent
+} -result {value for "-parent" missing}
+
+test fontchooser-1.7 {tk fontchooser: usage} -returnCodes error -body {
+    tk fontchooser configure -parent abc
+} -result {bad window path name "abc"}
+
+test fontchooser-1.8 {tk fontchooser: usage} -returnCodes ok -body {
+    tk fontchooser configure -visible
+} -result {0}
+
+test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body {
+    tk fontchooser configure -visible 1
+} -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]
+testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]
+
+test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body {
+    start {
+        tk::fontchooser::Configure -title "Hello"
+        tk::fontchooser::Show
+    }
+    then {
+        set x [wm title $::tk_dialog]
+        Click cancel
+    }
+    set x
+} -result {Hello}
+
+test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body {
+    start {
+        tk::fontchooser::Configure \
+            -title "\u041f\u0440\u0438\u0432\u0435\u0442"
+        tk::fontchooser::Show
+    }
+    then {
+        set x [wm title $::tk_dialog]
+        Click cancel
+    }
+    set x
+} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
+
+test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body {
+    start {
+        tk::fontchooser::Configure -parent .
+        tk::fontchooser::Show
+    }
+    then {
+        set x [winfo parent $::tk_dialog]
+        Click cancel
+    }
+    set x
+} -result {.}
+
+test fontchooser-3.1 {fontchooser -parent (invalid)} -constraints scriptImpl -body {
+    tk::fontchooser::Configure -parent junk
+} -returnCodes error -match glob -result {bad window path *}
+
+test fontchooser-4.0 {fontchooser -font} -constraints scriptImpl -body {
+    start {
+        tk::fontchooser::Configure -command ApplyFont -font courier
+        tk::fontchooser::Show
+    }
+    then {
+        Click cancel
+    }
+    set ::testfont
+} -result {}
+
+test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body {
+    start {
+        tk::fontchooser::Configure -command ApplyFont -font courier
+        tk::fontchooser::Show
+    }
+    then {
+        Click ok
+    }
+    expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body {
+    start {
+        tk::fontchooser::Configure -command ApplyFont -font TkDefaultFont
+        tk::fontchooser::Show
+    }
+    then {
+        Click ok
+    }
+    expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body {
+    start {
+        tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
+        tk::fontchooser::Show
+    }
+    then {
+        Click ok
+    }
+    expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.4 {fontchooser -font} -constraints scriptImpl -body {
+    start {
+        tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
+        tk::fontchooser::Show
+    }
+    then {
+        Click ok
+    }
+    lrange $::testfont 1 end
+} -result {14 bold}
+
+# -------------------------------------------------------------------------
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tests/winDialog.test b/tests/winDialog.test
index 5cc6e34..3a5c347 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.23 2008/11/22 12:22:12 patthoyts Exp $
+# RCS: @(#) $Id: winDialog.test,v 1.24 2008/12/10 05:02:52 das Exp $
 
 package require tcltest 2.2
 namespace import ::tcltest::*
@@ -34,6 +34,7 @@ proc start {arg} {
 proc then {cmd} {
     set ::command $cmd
     set ::dialogresult {}
+    set ::testfont {}
 
     afterbody
     vwait ::dialogresult
@@ -73,6 +74,10 @@ proc SetText {id text} {
     return [testwinevent $::tk_dialog $id WM_SETTEXT $text]
 }
 
+proc ApplyFont {font} {
+     set ::testfont $font
+}
+
 # ----------------------------------------------------------------------
 
 test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints {
@@ -516,6 +521,118 @@ test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFi
     tk_chooseDirectory -initialdir ~12x/455
 } -returnCodes error -result {user "12x" doesn't exist}
 
+
+test winDialog-10.1 {Tk_FontchooserObjCmd: no arguments} -constraints {
+    nt testwinevent
+} -body {
+    start {tk fontchooser show}
+    list [then {
+	Click cancel
+    }] $::testfont
+} -result {0 {}}
+test winDialog-10.2 {Tk_FontchooserObjCmd: -initialfont} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk fontchooser configure -command ApplyFont -font system
+        tk fontchooser show
+    }
+    list [then {
+	Click cancel
+    }] $::testfont
+} -result {0 {}}
+test winDialog-10.3 {Tk_FontchooserObjCmd: -initialfont} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk fontchooser configure -command ApplyFont -font system
+        tk fontchooser show
+    }
+    list [then {
+	Click 1
+    }] [expr {[llength $::testfont] ne {}}]
+} -result {0 1}
+test winDialog-10.4 {Tk_FontchooserObjCmd: -title} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk fontchooser configure -command ApplyFont -title "tk test"
+        tk fontchooser show
+    }
+    list [then {
+	Click cancel
+    }] $::testfont
+} -result {0 {}}
+test winDialog-10.5 {Tk_FontchooserObjCmd: -parent} -constraints {
+    nt testwinevent
+} -setup {
+    array set a {parent {}}
+} -body {
+    start {
+        tk fontchooser configure -command ApplyFont -parent .
+        tk fontchooser show
+    }
+    then {
+        array set a [testgetwindowinfo $::tk_dialog]
+	Click cancel
+    }
+    list [expr {$a(parent) == [wm frame .]}] $::testfont
+} -result {1 {}}
+test winDialog-10.6 {Tk_FontchooserObjCmd: -apply} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk fontchooser configure -command FooBarBaz
+        tk fontchooser show
+    }
+    then {
+	Click cancel
+    }
+} -result 0
+test winDialog-10.7 {Tk_FontchooserObjCmd: -apply} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk fontchooser configure -command ApplyFont -parent .
+        tk fontchooser show
+    }
+    list [then {
+	Click [expr {0x0402}] ;# value from XP
+        Click cancel
+    }] [expr {[llength $::testfont] > 0}]
+} -result {0 1}
+test winDialog-10.8 {Tk_FontchooserObjCmd: -title} -constraints {
+    nt testwinevent
+} -setup {
+    array set a {text failed}
+} -body {
+    start {
+        tk fontchooser configure -command ApplyFont -title "Hello"
+        tk fontchooser show
+    }
+    then {
+        array set a [testgetwindowinfo $::tk_dialog]
+        Click cancel
+    }
+    set a(text)
+} -result "Hello"
+test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints {
+    nt testwinevent
+} -setup {
+    array set a {text failed}
+} -body {
+    start {
+        tk fontchooser configure -command ApplyFont \
+            -title  "\u041f\u0440\u0438\u0432\u0435\u0442"
+        tk fontchooser show
+    }
+    then {
+        array set a [testgetwindowinfo $::tk_dialog]
+        Click cancel
+    }
+    set a(text)
+} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
+
 if {[testConstraint testwinevent]} {
     catch {testwinevent debug 0}
 }