An implementation of tk_chooseFont for TIP #213.

This version follows the API changes suggested by DAS to permit
MacOS support. The tk::choosefont command is now an ensemble with
configure, show and hide commands.

This patch provides a native Win32 font selection dialog and a ttk-based
pure-Tcl implementation for everyone else.

I've added a general-purpose TkMakeEnsemble to tkUtils.c

Some tests included

Adds a Font... menu item to the console.

Index: generic/tkInt.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkInt.h,v
retrieving revision 1.83
diff -u -r1.83 tkInt.h
--- generic/tkInt.h	2 Apr 2008 21:32:32 -0000	1.83
+++ generic/tkInt.h	10 May 2008 01:52:52 -0000
@@ -852,6 +852,17 @@
 } TkWindow;
 
 /*
+ * The following structure is used with TkMakeEnsemble to create
+ * ensemble commands and optionally to create sub-ensembles.
+ */
+
+typedef struct TkEnsemble {
+    const char *name;
+    Tcl_ObjCmdProc *proc;
+    const struct TkEnsemble *subensemble;
+} TkEnsemble;
+
+/*
  * The following structure is used as a two way map between integers and
  * strings, usually to map between an internal C representation and the
  * strings used in Tcl.
@@ -990,6 +1001,8 @@
 MODULE_SCOPE int	Tk_CheckbuttonObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	TkChoosefontInit(Tcl_Interp *interp, 
+			    ClientData clientData);
 MODULE_SCOPE int	Tk_ClipboardObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -1127,6 +1140,9 @@
 			    Tcl_FreeProc **freeProcPtr);
 MODULE_SCOPE int	TkGetDoublePixels(Tcl_Interp *interp, Tk_Window tkwin,
 			    const char *string, double *doublePtr);
+MODULE_SCOPE Tcl_Command TkMakeEnsemble(Tcl_Interp *interp, 
+			    const char *namespace, const char *name, 
+			    ClientData clientData, const TkEnsemble *map);
 MODULE_SCOPE int	TkOffsetParseProc(ClientData clientData,
 			    Tcl_Interp *interp, Tk_Window tkwin,
 			    const char *value, char *widgRec, int offset);
Index: generic/tkUtil.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkUtil.c,v
retrieving revision 1.21
diff -u -r1.21 tkUtil.c
--- generic/tkUtil.c	13 Dec 2007 15:24:21 -0000	1.21
+++ generic/tkUtil.c	10 May 2008 01:10:48 -0000
@@ -978,6 +978,90 @@
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * TkMakeEnsemble --
+ *
+ *	Create an ensemble from a table of implementation commands.
+ *	This may be called recursively to create sub-ensembles.
+ *
+ * Results:
+ *	Handle for the ensemble, or NULL if creation of it fails.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TkMakeEnsemble(
+    Tcl_Interp *interp,
+    const char *namespace,
+    const char *name,
+    ClientData clientData,
+    const TkEnsemble map[])
+{
+    Tcl_Namespace *namespacePtr = NULL;
+    Tcl_Command ensemble = NULL;
+    Tcl_Obj *dictObj = NULL;
+    Tcl_DString ds;
+    int i;
+
+    if (map == NULL) {
+	return NULL;
+    }
+
+    Tcl_DStringInit(&ds);
+
+    namespacePtr = Tcl_FindNamespace(interp, namespace, NULL, 0);
+    if (namespacePtr == NULL) {
+        namespacePtr = Tcl_CreateNamespace(interp, namespace, NULL, NULL);
+        if (namespacePtr == NULL) {
+            Tcl_Panic("failed to create namespace \"%s\"", namespace);
+        }
+    }
+
+    ensemble = Tcl_FindEnsemble(interp, Tcl_NewStringObj(name,-1), 0);
+    if (ensemble == NULL) {
+        ensemble = Tcl_CreateEnsemble(interp, name,
+	    namespacePtr, TCL_ENSEMBLE_PREFIX);
+        if (ensemble == NULL) {
+            Tcl_Panic("failed to create ensemble \"%s\"", name);
+        }
+    }
+    
+    Tcl_DStringSetLength(&ds, 0);
+    Tcl_DStringAppend(&ds, namespace, -1);
+    if (!(strlen(namespace) == 2 && namespace[1] == ':')) {
+	Tcl_DStringAppend(&ds, "::", -1);
+    }
+    Tcl_DStringAppend(&ds, name, -1);
+	
+    dictObj = Tcl_NewObj();
+    for (i = 0; map[i].name != NULL ; ++i) {
+	Tcl_Obj *nameObj, *fqdnObj;
+	
+	nameObj = Tcl_NewStringObj(map[i].name, -1);
+	fqdnObj = Tcl_NewStringObj(Tcl_DStringValue(&ds),
+	    Tcl_DStringLength(&ds));
+	Tcl_AppendStringsToObj(fqdnObj, "::", map[i].name, NULL);
+	Tcl_DictObjPut(NULL, dictObj, nameObj, fqdnObj);
+	if (map[i].proc) {
+	    Tcl_CreateObjCommand(interp, Tcl_GetString(fqdnObj),
+		map[i].proc, clientData, NULL);
+	} else {
+	    TkMakeEnsemble(interp, Tcl_DStringValue(&ds),
+		map[i].name, clientData, map[i].subensemble);
+	}
+    }
+
+    if (ensemble) {
+	Tcl_SetEnsembleMappingDict(interp, ensemble, dictObj);
+    }
+
+    Tcl_DStringFree(&ds);
+    return ensemble;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
Index: generic/tkWindow.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkWindow.c,v
retrieving revision 1.95
diff -u -r1.95 tkWindow.c
--- generic/tkWindow.c	27 Apr 2008 22:38:58 -0000	1.95
+++ generic/tkWindow.c	10 May 2008 02:15:19 -0000
@@ -94,11 +94,12 @@
  * The following structure defines all of the commands supported by Tk, and
  * the C functions that execute them.
  */
-
+typedef int (TkInitProc)(Tcl_Interp *interp, ClientData clientData);
 typedef struct {
     char *name;			/* Name of command. */
     Tcl_CmdProc *cmdProc;	/* Command's string-based function. */
     Tcl_ObjCmdProc *objProc;	/* Command's object-based function. */
+    TkInitProc *initProc;	/* Command's initialization function */
     int isSafe;			/* If !0, this command will be exposed in a
 				 * safe interpreter. Otherwise it will be
 				 * hidden in a safe interpreter. */
@@ -112,72 +113,72 @@
      * Commands that are part of the intrinsics:
      */
 
-    {"bell",		NULL,			Tk_BellObjCmd,		0, 1},
-    {"bind",		NULL,			Tk_BindObjCmd,		1, 1},
-    {"bindtags",	NULL,			Tk_BindtagsObjCmd,	1, 1},
-    {"clipboard",	NULL,			Tk_ClipboardObjCmd,	0, 1},
-    {"destroy",		NULL,			Tk_DestroyObjCmd,	1, 1},
-    {"event",		NULL,			Tk_EventObjCmd,		1, 1},
-    {"focus",		NULL,			Tk_FocusObjCmd,		1, 1},
-    {"font",		NULL,			Tk_FontObjCmd,		1, 1},
-    {"grab",		NULL,			Tk_GrabObjCmd,		0, 1},
-    {"grid",		NULL,			Tk_GridObjCmd,		1, 1},
-    {"image",		NULL,			Tk_ImageObjCmd,		1, 1},
-    {"lower",		NULL,			Tk_LowerObjCmd,		1, 1},
-    {"option",		NULL,			Tk_OptionObjCmd,	1, 1},
-    {"pack",		NULL,			Tk_PackObjCmd,		1, 1},
-    {"place",		NULL,			Tk_PlaceObjCmd,		1, 0},
-    {"raise",		NULL,			Tk_RaiseObjCmd,		1, 1},
-    {"selection",	NULL,			Tk_SelectionObjCmd,	0, 1},
-    {"tk",		NULL,			Tk_TkObjCmd,		1, 1},
-    {"tkwait",		NULL,			Tk_TkwaitObjCmd,	1, 1},
-    {"update",		NULL,			Tk_UpdateObjCmd,	1, 1},
-    {"winfo",		NULL,			Tk_WinfoObjCmd,		1, 1},
-    {"wm",		NULL,			Tk_WmObjCmd,		0, 1},
+    {"bell",		NULL,		Tk_BellObjCmd,		NULL, 0, 1},
+    {"bind",		NULL,		Tk_BindObjCmd,		NULL, 1, 1},
+    {"bindtags",	NULL,		Tk_BindtagsObjCmd,	NULL, 1, 1},
+    {"clipboard",	NULL,		Tk_ClipboardObjCmd,	NULL, 0, 1},
+    {"destroy",		NULL,		Tk_DestroyObjCmd,	NULL, 1, 1},
+    {"event",		NULL,		Tk_EventObjCmd,		NULL, 1, 1},
+    {"focus",		NULL,		Tk_FocusObjCmd,		NULL, 1, 1},
+    {"font",		NULL,		Tk_FontObjCmd,		NULL, 1, 1},
+    {"grab",		NULL,		Tk_GrabObjCmd,		NULL, 0, 1},
+    {"grid",		NULL,		Tk_GridObjCmd,		NULL, 1, 1},
+    {"image",		NULL,		Tk_ImageObjCmd,		NULL, 1, 1},
+    {"lower",		NULL,		Tk_LowerObjCmd,		NULL, 1, 1},
+    {"option",		NULL,		Tk_OptionObjCmd,	NULL, 1, 1},
+    {"pack",		NULL,		Tk_PackObjCmd,		NULL, 1, 1},
+    {"place",		NULL,		Tk_PlaceObjCmd,		NULL, 1, 0},
+    {"raise",		NULL,		Tk_RaiseObjCmd,		NULL, 1, 1},
+    {"selection",	NULL,		Tk_SelectionObjCmd,	NULL, 0, 1},
+    {"tk",		NULL,		Tk_TkObjCmd,		NULL, 1, 1},
+    {"tkwait",		NULL,		Tk_TkwaitObjCmd,	NULL, 1, 1},
+    {"update",		NULL,		Tk_UpdateObjCmd,	NULL, 1, 1},
+    {"winfo",		NULL,		Tk_WinfoObjCmd,		NULL, 1, 1},
+    {"wm",		NULL,		Tk_WmObjCmd,		NULL, 0, 1},
 
     /*
      * Default widget class commands.
      */
 
-    {"button",		NULL,			Tk_ButtonObjCmd,	1, 0},
-    {"canvas",		NULL,			Tk_CanvasObjCmd,	1, 1},
-    {"checkbutton",	NULL,			Tk_CheckbuttonObjCmd,	1, 0},
-    {"entry",		NULL,			Tk_EntryObjCmd,		1, 0},
-    {"frame",		NULL,			Tk_FrameObjCmd,		1, 0},
-    {"label",		NULL,			Tk_LabelObjCmd,		1, 0},
-    {"labelframe",	NULL,			Tk_LabelframeObjCmd,	1, 0},
-    {"listbox",		NULL,			Tk_ListboxObjCmd,	1, 0},
-    {"menubutton",	NULL,			Tk_MenubuttonObjCmd,	1, 0},
-    {"message",		NULL,			Tk_MessageObjCmd,	1, 0},
-    {"panedwindow",	NULL,			Tk_PanedWindowObjCmd,	1, 0},
-    {"radiobutton",	NULL,			Tk_RadiobuttonObjCmd,	1, 0},
-    {"scale",		NULL,			Tk_ScaleObjCmd,		1, 0},
-    {"scrollbar",	Tk_ScrollbarCmd,	NULL,			1, 1},
-    {"spinbox",		NULL,			Tk_SpinboxObjCmd,	1, 0},
-    {"text",		NULL,			Tk_TextObjCmd,		1, 1},
-    {"toplevel",	NULL,			Tk_ToplevelObjCmd,	0, 0},
+    {"button",		NULL,		Tk_ButtonObjCmd,	NULL, 1, 0},
+    {"canvas",		NULL,		Tk_CanvasObjCmd,	NULL, 1, 1},
+    {"checkbutton",	NULL,		Tk_CheckbuttonObjCmd,	NULL, 1, 0},
+    {"entry",		NULL,		Tk_EntryObjCmd,		NULL, 1, 0},
+    {"frame",		NULL,		Tk_FrameObjCmd,		NULL, 1, 0},
+    {"label",		NULL,		Tk_LabelObjCmd,		NULL, 1, 0},
+    {"labelframe",	NULL,		Tk_LabelframeObjCmd,	NULL, 1, 0},
+    {"listbox",		NULL,		Tk_ListboxObjCmd,	NULL, 1, 0},
+    {"menubutton",	NULL,		Tk_MenubuttonObjCmd,	NULL, 1, 0},
+    {"message",		NULL,		Tk_MessageObjCmd,	NULL, 1, 0},
+    {"panedwindow",	NULL,		Tk_PanedWindowObjCmd,	NULL, 1, 0},
+    {"radiobutton",	NULL,		Tk_RadiobuttonObjCmd,	NULL, 1, 0},
+    {"scale",		NULL,		Tk_ScaleObjCmd,		NULL, 1, 0},
+    {"scrollbar",	Tk_ScrollbarCmd,NULL,			NULL, 1, 1},
+    {"spinbox",		NULL,		Tk_SpinboxObjCmd,	NULL, 1, 0},
+    {"text",		NULL,		Tk_TextObjCmd,		NULL, 1, 1},
+    {"toplevel",	NULL,		Tk_ToplevelObjCmd,	NULL, 0, 0},
 
     /*
      * Classic widget class commands.
      */
 
-    {"::tk::button",	NULL,			Tk_ButtonObjCmd,	1, 0},
-    {"::tk::canvas",	NULL,			Tk_CanvasObjCmd,	1, 1},
-    {"::tk::checkbutton",NULL,			Tk_CheckbuttonObjCmd,	1, 0},
-    {"::tk::entry",	NULL,			Tk_EntryObjCmd,		1, 0},
-    {"::tk::frame",	NULL,			Tk_FrameObjCmd,		1, 0},
-    {"::tk::label",	NULL,			Tk_LabelObjCmd,		1, 0},
-    {"::tk::labelframe",NULL,			Tk_LabelframeObjCmd,	1, 0},
-    {"::tk::listbox",	NULL,			Tk_ListboxObjCmd,	1, 0},
-    {"::tk::menubutton",NULL,			Tk_MenubuttonObjCmd,	1, 0},
-    {"::tk::message",	NULL,			Tk_MessageObjCmd,	1, 0},
-    {"::tk::panedwindow",NULL,			Tk_PanedWindowObjCmd,	1, 0},
-    {"::tk::radiobutton",NULL,			Tk_RadiobuttonObjCmd,	1, 0},
-    {"::tk::scale",	NULL,			Tk_ScaleObjCmd,		1, 0},
-    {"::tk::scrollbar",	Tk_ScrollbarCmd,	NULL,			1, 1},
-    {"::tk::spinbox",	NULL,			Tk_SpinboxObjCmd,	1, 0},
-    {"::tk::text",	NULL,			Tk_TextObjCmd,		1, 1},
-    {"::tk::toplevel",	NULL,			Tk_ToplevelObjCmd,	0, 0},
+    {"::tk::button",	NULL,		Tk_ButtonObjCmd,	NULL, 1, 0},
+    {"::tk::canvas",	NULL,		Tk_CanvasObjCmd,	NULL, 1, 1},
+    {"::tk::checkbutton",NULL,		Tk_CheckbuttonObjCmd,	NULL, 1, 0},
+    {"::tk::entry",	NULL,		Tk_EntryObjCmd,		NULL, 1, 0},
+    {"::tk::frame",	NULL,		Tk_FrameObjCmd,		NULL, 1, 0},
+    {"::tk::label",	NULL,		Tk_LabelObjCmd,		NULL, 1, 0},
+    {"::tk::labelframe",NULL,		Tk_LabelframeObjCmd,	NULL, 1, 0},
+    {"::tk::listbox",	NULL,		Tk_ListboxObjCmd,	NULL, 1, 0},
+    {"::tk::menubutton",NULL,		Tk_MenubuttonObjCmd,	NULL, 1, 0},
+    {"::tk::message",	NULL,		Tk_MessageObjCmd,	NULL, 1, 0},
+    {"::tk::panedwindow",NULL,		Tk_PanedWindowObjCmd,	NULL, 1, 0},
+    {"::tk::radiobutton",NULL,		Tk_RadiobuttonObjCmd,	NULL, 1, 0},
+    {"::tk::scale",	NULL,		Tk_ScaleObjCmd,		NULL, 1, 0},
+    {"::tk::scrollbar",	Tk_ScrollbarCmd,NULL,			NULL, 1, 1},
+    {"::tk::spinbox",	NULL,		Tk_SpinboxObjCmd,	NULL, 1, 0},
+    {"::tk::text",	NULL,		Tk_TextObjCmd,		NULL, 1, 1},
+    {"::tk::toplevel",	NULL,		Tk_ToplevelObjCmd,	NULL, 0, 0},
 
     /*
      * Standard dialog support. Note that the Unix/X11 platform implements
@@ -185,11 +186,14 @@
      */
 
 #if defined(__WIN32__) || defined(MAC_OSX_TK)
-    {"tk_chooseColor",	NULL,			Tk_ChooseColorObjCmd,	0, 1},
-    {"tk_chooseDirectory", NULL,		Tk_ChooseDirectoryObjCmd,0,1},
-    {"tk_getOpenFile",	NULL,			Tk_GetOpenFileObjCmd,	0, 1},
-    {"tk_getSaveFile",	NULL,			Tk_GetSaveFileObjCmd,	0, 1},
-    {"tk_messageBox",	NULL,			Tk_MessageBoxObjCmd,	0, 1},
+    {"tk_chooseColor",	NULL,		Tk_ChooseColorObjCmd,	NULL, 0, 1},
+    {"tk_chooseDirectory", NULL,	Tk_ChooseDirectoryObjCmd,NULL, 0,1},
+    {"tk_getOpenFile",	NULL,		Tk_GetOpenFileObjCmd,	NULL, 0, 1},
+    {"tk_getSaveFile",	NULL,		Tk_GetSaveFileObjCmd,	NULL, 0, 1},
+    {"tk_messageBox",	NULL,		Tk_MessageBoxObjCmd,	NULL, 0, 1},
+#endif
+#if defined(__WIN32__)
+    {"::tk::choosefont",NULL,		NULL, TkChoosefontInit,	0, 1},
 #endif
 
     /*
@@ -198,9 +202,9 @@
 
 #if defined(MAC_OSX_TK)
     {"::tk::unsupported::MacWindowStyle",
-			NULL,			TkUnsupported1ObjCmd,	1, 1},
+			NULL,		TkUnsupported1ObjCmd,	NULL, 1, 1},
 #endif
-    {NULL,		NULL,			NULL,			0, 0}
+    {NULL,		NULL,		NULL,			NULL, 0, 0}
 };
 
 /*
@@ -948,7 +952,8 @@
 
     isSafe = Tcl_IsSafe(interp);
     for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) {
-	if ((cmdPtr->cmdProc == NULL) && (cmdPtr->objProc == NULL)) {
+	if ((cmdPtr->cmdProc == NULL) && (cmdPtr->objProc == NULL) 
+	    && (cmdPtr->initProc == NULL)) {
 	    Tcl_Panic("TkCreateMainWindow: builtin command with NULL string and object procs");
 	}
 	if (cmdPtr->passMainWindow) {
@@ -956,7 +961,9 @@
 	} else {
 	    clientData = NULL;
 	}
-	if (cmdPtr->cmdProc != NULL) {
+	if (cmdPtr->initProc != NULL) {
+	    cmdPtr->initProc(interp, clientData);
+	} else if (cmdPtr->cmdProc != NULL) {
 	    Tcl_CreateCommand(interp, cmdPtr->name, cmdPtr->cmdProc,
 		    clientData, NULL);
 	} else {
Index: library/console.tcl
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/console.tcl,v
retrieving revision 1.38
diff -u -r1.38 console.tcl
--- library/console.tcl	13 May 2008 13:25:18 -0000	1.38
+++ library/console.tcl	14 May 2008 22:17:29 -0000
@@ -25,7 +25,7 @@
 
     variable inPlugin [info exists embed_args]
     variable defaultPrompt   ; # default prompt if tcl_prompt1 isn't used
-
+    variable fontChooser [dict create action show index -1]
 
     if {$inPlugin} {
 	set defaultPrompt {subst {[history nextid] % }}
@@ -98,10 +98,22 @@
     }
 
     AmpMenuArgs .menubar.edit add separator
-    AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
-        -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
-    AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
-        -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
+    if {[llength [info command ::tk::choosefont]] != 0} {
+        if {[tk windowingsystem] eq "aqua"} {
+            .menubar.edit add command -label [mc "Show Fonts"]\
+                -accelerator "$mod-T" -command ::tk::console::ChooseFont
+            dict set ::tk::console::fontChooser index \
+                [.menubar.edit index [mc "Show Fonts"]]
+        } else {
+            AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
+                -command ::tk::console::ChooseFont
+        }
+    } else {
+        AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
+            -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
+        AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
+            -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
+    }
 
     . configure -menu .menubar
 
@@ -396,7 +408,9 @@
 	    event add $ev $key
 	    bind Console $key {}
 	}
+        bind Console <Command-Key-t> ::tk::console::ChooseFont
     }
+
     bind Console <<Console_Expand>> {
 	if {[%W compare insert > promptEnd]} {
 	    ::tk::console::Expand %W
@@ -669,6 +683,38 @@
 Tk $::tk_patchLevel"
 }
 
+# ::tk::console::ChooseFont --
+# 	Let the user select the console font.
+
+proc ::tk::console::ChooseFont {} {
+    variable fontChooser
+    if {[llength [info command ::tk::choosefont]] == 0} {
+        return
+    }
+
+    if {[dict get $fontChooser action] eq "show"} {
+        ::tk::choosefont configure \
+            -parent .console \
+            -font TkConsoleFont \
+            -command [namespace code [list ApplyFont]]
+        ::tk::choosefont show
+        if {[set index [dict get $fontChooser index]] != -1} {
+            .menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"]
+            dict set fontChooser action "hide"
+        }
+    } else {
+        ::tk::choosefont hide
+        if {[set index [dict get $fontChooser index]] != -1} {
+            .menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"]
+            dict set fontChooser action "show"
+        }
+    }
+}
+proc ::tk::console::ApplyFont {font} {
+    font configure TkConsoleFont {*}[font actual $font]
+}
+
+    
 # ::tk::console::TagProc --
 #
 # Tags a procedure in the console if it's recognized
Index: library/fontdlg.tcl
===================================================================
RCS file: library/fontdlg.tcl
diff -N library/fontdlg.tcl
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ library/fontdlg.tcl	20 Apr 2008 16:14:15 -0000
@@ -0,0 +1,366 @@
+# fontdlg.tcl - 
+#
+#	A themeable Tk font selection dialog. See TIP #213.
+#
+# Copyright (C) 2008 Keith Vetter
+# Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id$
+
+namespace eval ::tk::choosefont {
+    variable S
+
+    set S(W) .__tk__chooseFont
+    set S(fonts) [lsort -dictionary [font families]]
+    set S(styles) [list \
+                       [::msgcat::mc "Regular"] \
+                       [::msgcat::mc "Italic"] \
+                       [::msgcat::mc "Bold"] \
+                       [::msgcat::mc "Bold Italic"] \
+                      ]
+
+    set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72}
+    set S(strike) 0
+    set S(under) 0
+    set S(first) 1
+    set S(sampletext) [::msgcat::mc "AaBbYyZz01"]
+    set S(-parent) .
+    set S(-title) [::msgcat::mc "Font"]
+
+    # Canonical versions of font families, styles, etc. for easier searching
+    set S(fonts,lcase) {}
+    foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}
+    set S(styles,lcase) {}
+    foreach style $S(styles) { lappend S(styles,lcase) [string tolower $style]}
+    set S(sizes,lcase) $S(sizes)
+
+    ::ttk::style layout ChoosefontFrame {
+        Entry.field -sticky news -border true -children {
+            ChoosefontFrame.padding -sticky news
+        }
+    }
+    bind [winfo class .] <<ThemeChanged>> \
+        [list ttk::style layout ChoosefontFrame \
+             [ttk::style layout ChoosefontFrame]]
+
+    namespace ensemble create -map {
+        show ::tk::choosefont::Show
+        hide ::tk::choosefont::Hide
+        configure ::tk::choosefont::Configure
+    }
+}
+
+proc ::tk::choosefont::Show {} {
+    variable S
+    if {![winfo exists $S(W)]} { Configure }
+    wm transient $S(W) [winfo toplevel $S(-parent)]
+    tk::PlaceWindow $S(W) widget $S(-parent)
+    wm deiconify $S(W)
+}
+proc ::tk::choosefont::Hide {} {
+    variable S
+    wm withdraw $S(W)
+}
+
+proc ::tk::choosefont::Configure {args} {
+    variable S
+    
+    set windowName __tk__choosefont
+    
+    set specs {
+        {-parent "" "" .}
+        {-title "" "" " "}
+        {-font "" "" ""}
+        {-command "" "" ""}
+    }
+
+    tclParseConfigSpec [namespace which -variable S] $specs "" $args
+    if {[string trim $S(-title)] eq ""} {
+        set S(-title) [::msgcat::mc "Font"]
+    }
+    if {$S(-parent) eq "."} {
+        set S(W) .$windowName
+    } else {
+        set S(W) $S(-parent).$windowName
+    }
+
+    # Now build the dialog
+    if {![winfo exists $S(W)]} {
+        toplevel $S(W) -class TkFontDialog
+        if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)}
+        wm withdraw $S(W)
+        wm title $S(W) $S(-title)
+        wm transient $S(W) [winfo toplevel $S(-parent)]
+        wm geometry $S(W) 430x316
+        
+        set outer [::ttk::frame $S(W).outer -padding {10 10}]
+        ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"]
+        ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"]
+        ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"]
+        ttk::entry $S(W).efont -textvariable [namespace which -variable S](font)
+        ttk::entry $S(W).estyle -textvariable [namespace which -variable S](style)
+        ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
+            -width 0 -validate key -validatecommand {string is double %P}
+        
+        ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \
+            -selectmode browse -activestyle none \
+            -listvariable [namespace which -variable S](fonts) 
+        ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \
+            -selectmode browse -activestyle none \
+            -listvariable [namespace which -variable S](styles)
+        ttk_slistbox $S(W).lsizes -width 6 -height 7 -exportselection 0 \
+            -selectmode browse -activestyle none \
+            -listvariable [namespace which -variable S](sizes) \
+            
+        set WE $S(W).effects
+        ::ttk::labelframe $WE -text [::msgcat::mc "Effects"]
+        ::tk::AmpWidget ::ttk::checkbutton $WE.strike \
+            -variable [namespace which -variable S](strike) \
+            -text [::msgcat::mc "Stri&keout"] \
+            -command [namespace code [list Click strike]]
+        ::tk::AmpWidget ::ttk::checkbutton $WE.under \
+            -variable [namespace which -variable S](under) \
+            -text [::msgcat::mc "&Underline"] \
+            -command [namespace code [list Click under]]
+        
+        set bbox [::ttk::frame $S(W).bbox]
+        ::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\
+            -command [namespace code [list Done 1]]
+        ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \
+            -command [namespace code [list Done 0]]
+        ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \
+            -command [namespace code [list Apply]]
+        wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]]
+        
+        bind $S(W) <Return> [namespace code [list Done 1]]
+        bind $S(W) <Escape> [namespace code [list Done 0]]
+        bind $S(W).lfonts.list <<ListboxSelect>> [namespace code [list Click font]]
+        bind $S(W).lstyles.list <<ListboxSelect>> [namespace code [list Click style]]
+        bind $S(W).lsizes.list <<ListboxSelect>> [namespace code [list Click size]]
+        bind $S(W) <Alt-Key> [list ::tk::AltKeyInDialog $S(W) %A]
+        bind $S(W).font <<AltUnderlined>> [list ::focus $S(W).efont]
+        bind $S(W).style <<AltUnderlined>> [list ::focus $S(W).estyle]
+        bind $S(W).size <<AltUnderlined>> [list ::focus $S(W).esize]
+        bind $S(W).apply <<AltUnderlined>> [namespace code [list Apply]]
+        bind $WE.strike <<AltUnderlined>> [list $WE.strike invoke]
+        bind $WE.under <<AltUnderlined>> [list $WE.under invoke]
+        
+        set WS $S(W).sample
+        ::ttk::labelframe $WS -text [::msgcat::mc "Sample"]
+        ::ttk::label $WS.sample -relief sunken -anchor center \
+            -textvariable [namespace which -variable S](sampletext)
+        set S(sample) $WS.sample
+        grid $WS.sample -sticky news -padx 8 -pady 6
+        grid rowconfigure $WS 0 -weight 1
+        grid columnconfigure $WS 0 -weight 1
+        grid propagate $WS 0
+        
+        grid $S(W).ok     -in $bbox -sticky new -pady {0 2}
+        grid $S(W).cancel -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
+        grid $WE.under -sticky w -padx 10 -pady {0 30}
+        grid columnconfigure $WE 1 -weight 1
+        
+        grid $S(W).font   x $S(W).style   x $S(W).size   x       -in $outer -sticky w
+        grid $S(W).efont  x $S(W).estyle  x $S(W).esize  x $bbox -in $outer -sticky ew
+        grid $S(W).lfonts x $S(W).lstyles x $S(W).lsizes x ^     -in $outer -sticky news
+        grid $WE          x $WS           - -            x ^     -in $outer -sticky news -pady {15 30}
+        grid configure $bbox -sticky n
+        grid columnconfigure $outer {1 3 5} -minsize 10
+        grid columnconfigure $outer {0 2 4} -weight 1
+        
+        grid $outer -sticky news
+        grid rowconfigure $S(W) 0 -weight 1
+        grid columnconfigure $S(W) 0 -weight 1
+        
+        Init $S(-font)
+        
+        trace add variable [namespace which -variable S](size) \
+            write [namespace code [list Tracer]]
+        trace add variable [namespace which -variable S](style) \
+            write [namespace code [list Tracer]]
+        trace add variable [namespace which -variable S](font) \
+            write [namespace code [list Tracer]]
+    } else {
+        Init $S(-font)
+    }
+
+    return
+}
+
+# ::tk::choosefont::Done --
+#
+#       Handles teardown of the dialog, calling -command if needed
+#
+# Arguments:
+#       ok              true if user pressed OK
+#
+proc ::tk::::choosefont::Done {ok} {
+    variable S
+    
+    if {! $ok} {
+        set S(result) ""
+    }
+    trace vdelete S(size) w [namespace code [list Tracer]]
+    trace vdelete S(style) w [namespace code [list Tracer]]
+    trace vdelete S(font) w [namespace code [list Tracer]]
+    destroy $S(W)
+    if {$ok && $S(-command) ne ""} {
+        uplevel #0 $S(-command) [list $S(result)]
+    }
+}
+
+# ::tk::choosefont::Apply --
+#
+#	Call the -command procedure appending the current font
+#	Errors are reported via the background error mechanism
+#
+proc ::tk::choosefont::Apply {} {
+    variable S
+    if {$S(-command) ne ""} {
+        if {[catch {uplevel #0 $S(-command) [list $S(result)]} err]} {
+            ::bgerror $err
+        }
+    }
+}
+
+# ::tk::choosefont::Init --
+#
+#       Initializes dialog to a default font
+#
+# Arguments:
+#       defaultFont     font to use as the default
+#
+proc ::tk::choosefont::Init {{defaultFont ""}} {
+    variable S
+
+    if {$S(first) || $defaultFont ne ""} {
+        if {$defaultFont eq ""} {
+            set defaultFont [[entry .___e] cget -font]
+            destroy .___e
+        }
+        array set F [font actual $defaultFont]
+        set S(font) $F(-family)
+        set S(size) $F(-size)
+        set S(strike) $F(-overstrike)
+        set S(under) $F(-underline)
+        set S(style) "Regular"
+        if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} {
+            set S(style) "Bold Italic"
+        } elseif {$F(-weight) eq "bold"} {
+            set S(style) "Bold"
+        } elseif {$F(-slant) eq "italic"} {
+            set S(style) "Italic"
+        }
+
+        set S(first) 0
+    }
+
+    Tracer a b c
+    Update
+}
+
+# ::tk::choosefont::Click --
+#
+#       Handles all button clicks, updating the appropriate widgets
+#
+# Arguments:
+#       who             which widget got pressed
+#
+proc ::tk::choosefont::Click {who} {
+    variable S
+
+    if {$who eq "font"} {
+        set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]]
+    } elseif {$who eq "style"} {
+        set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]]
+    } elseif {$who eq "size"} {
+        set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]]
+    }
+    Update
+}
+
+# ::tk::choosefont::Tracer --
+#
+#       Handles traces on key variables, updating the appropriate widgets
+#
+# Arguments:
+#       standard trace arguments (not used)
+#
+proc ::tk::choosefont::Tracer {var1 var2 op} {
+    variable S
+
+    set bad 0
+    set nstate normal
+    # Make selection in each listbox
+    foreach var {font style size} {
+        set value [string tolower $S($var)]
+        $S(W).l${var}s selection clear 0 end
+        set n [lsearch -exact $S(${var}s,lcase) $value]
+        $S(W).l${var}s selection set $n
+        if {$n != -1} {
+            set S($var) [lindex $S(${var}s) $n]
+            $S(W).e$var icursor end
+            $S(W).e$var selection clear
+        } else {                                ;# No match, try prefix
+            # Size is weird: valid numbers are legal but don't display
+            # unless in the font size list
+            set n [lsearch -glob $S(${var}s,lcase) "$value*"]
+            set bad 1
+            if {$var ne "size" || ! [string is double -strict $value]} {
+                set nstate disabled
+            }
+        }
+        $S(W).l${var}s see $n
+    }
+    if {!$bad} { Update }
+    $S(W).ok config -state $nstate
+}
+
+# ::tk::choosefont::Update --
+#
+#       Shows a sample of the currently selected font
+#
+proc ::tk::choosefont::Update {} {
+    variable S
+
+    set S(result) [list $S(font) $S(size)]
+    if {$S(style) eq "Bold"} { lappend S(result) bold }
+    if {$S(style) eq "Italic"} { lappend S(result) italic }
+    if {$S(style) eq "Bold Italic"} { lappend S(result) bold italic}
+    if {$S(strike)} { lappend S(result) overstrike}
+    if {$S(under)} { lappend S(result) underline}
+
+    $S(sample) config -font $S(result)
+}
+
+# ::tk::choosefont::ttk_listbox --
+#
+#	Create a properly themed scrolled listbox.
+#	This is exactly right on XP but may need adjusting on other platforms.
+#
+proc ::tk::choosefont::ttk_slistbox {w args} {
+    set f [ttk::frame $w -style ChoosefontFrame -padding 2]
+    if {[catch {
+        listbox $f.list -relief flat -highlightthickness 0 -borderwidth 0 {*}$args
+        ttk::scrollbar $f.vs -command [list $f.list yview]
+        $f.list configure -yscrollcommand [list $f.vs set]
+        grid $f.list $f.vs -sticky news
+        grid rowconfigure $f 0 -weight 1
+        grid columnconfigure $f 0 -weight 1
+        interp hide {} $w
+        interp alias {} $w {} $f.list
+    } err]} {
+        destroy $f
+        return -code error $err
+    }
+    return $w
+}
Index: library/tclIndex
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/tclIndex,v
retrieving revision 1.10
diff -u -r1.10 tclIndex
--- library/tclIndex	30 Oct 2007 01:57:54 -0000	1.10
+++ library/tclIndex	10 May 2008 07:33:20 -0000
@@ -276,3 +276,4 @@
 set auto_index(tk_getFileType) [list source [file join $dir xmfbox.tcl]]
 set auto_index(::tk::unsupported::ExposePrivateCommand) [list source [file join $dir unsupported.tcl]]
 set auto_index(::tk::unsupported::ExposePrivateVariable) [list source [file join $dir unsupported.tcl]]
+set auto_index(::tk::choosefont) [list source [file join $dir fontdlg.tcl]]
Index: library/tk.tcl
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/tk.tcl,v
retrieving revision 1.75
diff -u -r1.75 tk.tcl
--- library/tk.tcl	11 May 2008 00:47:22 -0000	1.75
+++ library/tk.tcl	14 May 2008 22:36:01 -0000
@@ -350,6 +350,11 @@
 	return [::tk::dialog::file::chooseDir:: {*}$args]
     }
 }
+#if {![llength [info commands tk_chooseFont]]} {
+#    proc ::tk_chooseFont {args} {
+#        return [::tk::choosefont {*}$args]
+#    }
+#}
 
 #----------------------------------------------------------------------
 # Define the set of common virtual events.
Index: library/msgs/de.msg
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/msgs/de.msg,v
retrieving revision 1.7
diff -u -r1.7 de.msg
--- library/msgs/de.msg	14 Nov 2007 14:07:04 -0000	1.7
+++ library/msgs/de.msg	18 Apr 2008 08:58:58 -0000
@@ -5,6 +5,7 @@
     ::msgcat::mcset de "Application Error" "Applikationsfehler"
     ::msgcat::mcset de "&Blue" "&Blau"
     ::msgcat::mcset de "&Cancel" "&Abbruch"
+    ::msgcat::mcset de "Cancel" "Abbruch"
     ::msgcat::mcset de "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kann nicht in das Verzeichnis \"%1\$s\" wechseln.\nKeine Rechte vorhanden."
     ::msgcat::mcset de "Choose Directory" "W\u00e4hle Verzeichnis"
     ::msgcat::mcset de "&Clear" "&R\u00fccksetzen"
Index: library/msgs/en.msg
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/msgs/en.msg,v
retrieving revision 1.6
diff -u -r1.6 en.msg
--- library/msgs/en.msg	6 Dec 2007 16:05:47 -0000	1.6
+++ library/msgs/en.msg	18 Apr 2008 09:03:58 -0000
@@ -3,7 +3,11 @@
     ::msgcat::mcset en "&About..."
     ::msgcat::mcset en "All Files"
     ::msgcat::mcset en "Application Error"
+    ::msgcat::mcset en "&Apply"
+    ::msgcat::mcset en "Bold"
+    ::msgcat::mcset en "Bold Italic"
     ::msgcat::mcset en "&Blue"
+    ::msgcat::mcset en "Cancel"
     ::msgcat::mcset en "&Cancel"
     ::msgcat::mcset en "Cannot change to the directory \"%1\$s\".\nPermission denied."
     ::msgcat::mcset en "Choose Directory"
@@ -18,6 +22,7 @@
     ::msgcat::mcset en "Directory \"%1\$s\" does not exist."
     ::msgcat::mcset en "&Directory:"
     ::msgcat::mcset en "&Edit"
+    ::msgcat::mcset en "Effects"
     ::msgcat::mcset en "Error: %1\$s"
     ::msgcat::mcset en "E&xit"
     ::msgcat::mcset en "&File"
@@ -30,15 +35,20 @@
     ::msgcat::mcset en "Fi&les:"
     ::msgcat::mcset en "&Filter"
     ::msgcat::mcset en "Fil&ter:"
+    ::msgcat::mcset en "Font"
+    ::msgcat::mcset en "&Font:"
+    ::msgcat::mcset en "Font st&yle:"
     ::msgcat::mcset en "&Green"
     ::msgcat::mcset en "&Help"
     ::msgcat::mcset en "Hi"
     ::msgcat::mcset en "&Hide Console"
     ::msgcat::mcset en "&Ignore"
     ::msgcat::mcset en "Invalid file name \"%1\$s\"."
+    ::msgcat::mcset en "Italic"
     ::msgcat::mcset en "Log Files"
     ::msgcat::mcset en "&No"
     ::msgcat::mcset en "&OK"
+    ::msgcat::mcset en "OK"
     ::msgcat::mcset en "Ok"
     ::msgcat::mcset en "Open"
     ::msgcat::mcset en "&Open"
@@ -46,21 +56,26 @@
     ::msgcat::mcset en "P&aste"
     ::msgcat::mcset en "&Quit"
     ::msgcat::mcset en "&Red"
+    ::msgcat::mcset en "Regular"
     ::msgcat::mcset en "Replace existing file?"
     ::msgcat::mcset en "&Retry"
+    ::msgcat::mcset en "Sample"
     ::msgcat::mcset en "&Save"
     ::msgcat::mcset en "Save As"
     ::msgcat::mcset en "Save To Log"
     ::msgcat::mcset en "Select Log File"
     ::msgcat::mcset en "Select a file to source"
     ::msgcat::mcset en "&Selection:"
+    ::msgcat::mcset en "&Size:"
     ::msgcat::mcset en "Show &Hidden Directories"
     ::msgcat::mcset en "Show &Hidden Files and Directories"
     ::msgcat::mcset en "Skip Messages"
     ::msgcat::mcset en "&Source..."
+    ::msgcat::mcset en "Stri&keout"
     ::msgcat::mcset en "Tcl Scripts"
     ::msgcat::mcset en "Tcl for Windows"
     ::msgcat::mcset en "Text Files"
+    ::msgcat::mcset en "&Underline"
     ::msgcat::mcset en "&Yes"
     ::msgcat::mcset en "abort"
     ::msgcat::mcset en "blue"
Index: tests/fontdlg.test
===================================================================
RCS file: tests/fontdlg.test
diff -N tests/fontdlg.test
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/fontdlg.test	10 May 2008 20:26:51 -0000
@@ -0,0 +1,198 @@
+# Test the "tk::choosefont" command
+#
+# Copyright (c) 2008 Pat Thoyts
+#
+# RCS: @(#) $Id$
+#
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# for forcing a test of the script version when a native one exists
+#rename ::tk_chooseFont ::tk_chooseFontA
+#interp alias {} ::tk_chooseFont {} ::tk::choosefont::choosefont
+
+# 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).
+
+testConstraint scriptImpl [llength [info proc ::tk::choosefont::Configure]]
+
+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 fontdlg-1.1 {tk::choosefont: usage} -returnCodes error -body {
+    tk::choosefont -z
+} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show}
+
+test fontdlg-1.2 {tk::choosefont: usage} -returnCodes error -body {
+    tk::choosefont configure -z
+} -match glob -result {bad option "-z":*}
+
+test fontdlg-1.3 {tk::choosefont: usage} -returnCodes error -body {
+    tk::choosefont configure -font
+} -result {value for "-font" missing}
+
+test fontdlg-1.4 {tk::choosefont: usage} -returnCodes error -body {
+    tk::choosefont configure -title
+} -result {value for "-title" missing}
+
+test fontdlg-1.5 {tk::choosefont: usage} -returnCodes error -body {
+    tk::choosefont configure -command
+} -result {value for "-command" missing}
+
+test fontdlg-1.6 {tk::choosefont: usage} -returnCodes error -body {
+    tk::choosefont configure -parent
+} -result {value for "-parent" missing}
+
+test fontdlg-1.7 {tk::choosefont: usage} -returnCodes error -body {
+    tk::choosefont configure -parent abc
+} -result {bad window path name "abc"}
+
+# -------------------------------------------------------------------------
+# 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.
+
+test fontdlg-2.0 {choosefont -title} -constraints scriptImpl -body {
+    start {
+        tk::choosefont configure -title "Hello"
+        tk::choosefont show
+    }
+    then {
+        set x [wm title $::tk_dialog]
+        Click cancel
+    }
+    set x
+} -result {Hello}
+
+test fontdlg-2.1 {choosefont -title (cyrillic)} -constraints scriptImpl -body {
+    start {
+        tk::choosefont configure \
+            -title "\u041f\u0440\u0438\u0432\u0435\u0442"
+        tk::choosefont show
+    }
+    then {
+        set x [wm title $::tk_dialog]
+        Click cancel
+    }
+    set x
+} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
+
+test fontdlg-3.0 {choosefont -parent} -constraints scriptImpl -body {
+    start {
+        tk::choosefont configure -parent .
+        tk::choosefont show
+    }
+    then {
+        set x [winfo parent $::tk_dialog]
+        Click cancel
+    }
+    set x
+} -result {.}
+
+test fontdlg-3.1 {choosefont -parent (invalid)} -body {
+    tk::choosefont configure -parent junk
+} -returnCodes error -match glob -result {bad window path *}
+
+test fontdlg-4.0 {choosefont -font} -constraints scriptImpl -body {
+    start {
+        tk::choosefont configure -command ApplyFont -font courier
+        tk::choosefont show
+    }
+    then {
+        Click cancel
+    }
+    set ::testfont
+} -result {}
+
+test fontdlg-4.1 {choosefont -font} -constraints scriptImpl -body {
+    start {
+        tk::choosefont configure -command ApplyFont -font courier
+        tk::choosefont show
+    }
+    then {
+        Click ok
+    }
+    expr {$::testfont ne {}}
+} -result {1}
+
+test fontdlg-4.2 {choosefont -font} -constraints scriptImpl -body {
+    start {
+        tk::choosefont configure -command ApplyFont -font TkDefaultFont
+        tk::choosefont show
+    }
+    then {
+        Click ok
+    }
+    expr {$::testfont ne {}}
+} -result {1}
+
+test fontdlg-4.3 {choosefont -font} -constraints scriptImpl -body {
+    start {
+        tk::choosefont configure -command ApplyFont -font {times 14 bold}
+        tk::choosefont show
+    }
+    then {
+        Click ok
+    }
+    expr {$::testfont ne {}}
+} -result {1}
+
+test fontdlg-4.4 {choosefont -font} -constraints scriptImpl -body {
+    start {
+        tk::choosefont configure -command ApplyFont -font {times 14 bold}
+        tk::choosefont show
+    }
+    then {
+        Click ok
+    }
+    lrange $::testfont 1 end
+} -result {14 bold}
+
+# -------------------------------------------------------------------------
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
\ No newline at end of file
Index: tests/winDialog.test
===================================================================
RCS file: /cvsroot/tktoolkit/tk/tests/winDialog.test,v
retrieving revision 1.17
diff -u -r1.17 winDialog.test
--- tests/winDialog.test	13 May 2008 12:39:28 -0000	1.17
+++ tests/winDialog.test	14 May 2008 22:17:32 -0000
@@ -27,6 +27,7 @@
 proc then {cmd} {
     set ::command $cmd
     set ::dialogresult {}
+    set ::testfont {}
 
     afterbody
     vwait ::dialogresult
@@ -58,6 +59,10 @@
     return [testwinevent $::tk_dialog $button WM_SETTEXT $text]
 }
 
+proc ApplyFont {font} {
+     set ::testfont $font
+}
+
 test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints {
     testwinevent
 } -body {
@@ -411,6 +416,118 @@
     list [catch {tk_chooseDirectory -initialdir ~12x/455} msg] $msg
 } {1 {user "12x" doesn't exist}}
 
+
+test winDialog-10.1 {Tk_ChooseFontObjCmd: no arguments} -constraints {
+    nt testwinevent
+} -body {
+    start {tk::choosefont show}
+    list [then {
+	Click cancel
+    }] $::testfont
+} -result {0 {}}
+test winDialog-10.2 {Tk_ChooseFontObjCmd: -initialfont} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk::choosefont configure -command ApplyFont -font system
+        tk::choosefont show
+    }
+    list [then {
+	Click cancel
+    }] $::testfont
+} -result {0 {}}
+test winDialog-10.3 {Tk_ChooseFontObjCmd: -initialfont} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk::choosefont configure -command ApplyFont -font system
+        tk::choosefont show
+    }
+    list [then {
+	Click 1
+    }] [expr {[llength $::testfont] ne {}}]
+} -result {0 1}
+test winDialog-10.4 {Tk_ChooseFontObjCmd: -title} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk::choosefont configure -command ApplyFont -title "tk test"
+        tk::choosefont show
+    }
+    list [then {
+	Click cancel
+    }] $::testfont
+} -result {0 {}}
+test winDialog-10.5 {Tk_ChooseFontObjCmd: -parent} -constraints {
+    nt testwinevent
+} -setup {
+    array set a {parent {}}
+} -body {
+    start {
+        tk::choosefont configure -command ApplyFont -parent .
+        tk::choosefont show
+    }
+    then {
+        array set a [testgetwindowinfo $::tk_dialog]
+	Click cancel
+    }
+    list [expr {$a(parent) == [wm frame .]}] $::testfont
+} -result {1 {}}
+test winDialog-10.6 {Tk_ChooseFontObjCmd: -apply} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk::choosefont configure -command FooBarBaz
+        tk::choosefont show
+    }
+    then {
+	Click cancel
+    }
+} -result 0
+test winDialog-10.7 {Tk_ChooseFontObjCmd: -apply} -constraints {
+    nt testwinevent
+} -body {
+    start {
+        tk::choosefont configure -command ApplyFont -parent .
+        tk::choosefont show
+    }
+    list [then {
+	Click [expr {0x0402}] ;# value from XP
+        Click cancel
+    }] [expr {[llength $::testfont] > 0}]
+} -result {0 1}
+test winDialog-10.8 {Tk_ChooseFontObjCmd: -title} -constraints {
+    nt testwinevent
+} -setup {
+    array set a {text failed}
+} -body {
+    start {
+        tk::choosefont configure -command ApplyFont -title "Hello"
+        tk::choosefont show
+    }
+    then {
+        array set a [testgetwindowinfo $::tk_dialog]
+        Click cancel
+    }
+    set a(text)
+} -result "Hello"
+test winDialog-10.9 {Tk_ChooseFontObjCmd: -title} -constraints {
+    nt testwinevent
+} -setup {
+    array set a {text failed}
+} -body {
+    start {
+        tk::choosefont configure -command ApplyFont \
+            -title  "\u041f\u0440\u0438\u0432\u0435\u0442"
+        tk::choosefont 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}
 }
Index: win/tkWinDialog.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinDialog.c,v
retrieving revision 1.52
diff -u -r1.52 tkWinDialog.c
--- win/tkWinDialog.c	27 Apr 2008 22:39:14 -0000	1.52
+++ win/tkWinDialog.c	10 May 2008 20:46:49 -0000
@@ -14,6 +14,7 @@
 
 #include "tkWinInt.h"
 #include "tkFileFilter.h"
+#include "tkFont.h"
 
 #include <commdlg.h>		/* includes common dialog functionality */
 #ifdef _MSC_VER
@@ -2295,6 +2296,434 @@
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * BackgroundEvalObjv --
+ *
+ *	Evaluate a command while ensuring that we do not affect the 
+ *	interpreters state. This is important when evaluating script
+ *	during background tasks.
+ *
+ * Results:
+ *	A standard Tcl result code.
+ *
+ * Side Effects:
+ *	The interpreters variables and code may be modified by the script
+ *	but the result will not be modified.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+BackgroundEvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv,
+    int flags)
+{
+    Tcl_DString errorInfo, errorCode;
+    Tcl_SavedResult state;
+    int n, r = TCL_OK;
+    
+    Tcl_DStringInit(&errorInfo);
+    Tcl_DStringInit(&errorCode);
+
+    Tcl_Preserve(interp);
+
+    /*
+     * Record the state of the interpreter
+     */
+
+    Tcl_SaveResult(interp, &state);
+    Tcl_DStringAppend(&errorInfo, 
+	Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1);
+    Tcl_DStringAppend(&errorCode, 
+	Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY), -1);
+    
+    /*
+     * Evaluate the command and handle any error.
+     */
+
+    for (n = 0; n < objc; ++n) {
+	Tcl_IncrRefCount(objv[n]);
+    }
+    r = Tcl_EvalObjv(interp, objc, objv, flags);
+    for (n = 0; n < objc; ++n) {
+	Tcl_DecrRefCount(objv[n]);
+    }
+    if (r == TCL_ERROR) {
+        Tcl_AddErrorInfo(interp, "\n    (background event handler)");
+        Tcl_BackgroundError(interp);
+    }
+
+    Tcl_Release(interp);
+
+    /*
+     * Restore the state of the interpreter
+     */
+    
+    Tcl_SetVar(interp, "errorInfo",
+	Tcl_DStringValue(&errorInfo), TCL_GLOBAL_ONLY);
+    Tcl_SetVar(interp, "errorCode",
+	Tcl_DStringValue(&errorCode), TCL_GLOBAL_ONLY);
+    Tcl_RestoreResult(interp, &state);
+    
+    /*
+     * Clean up references.
+     */
+    
+    Tcl_DStringFree(&errorInfo);
+    Tcl_DStringFree(&errorCode);
+    
+    return r;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ * GetFontObj --
+ *
+ *	Convert a windows LOGFONT into a Tk font description.
+ *
+ * Result:
+ *	A list containing a Tk font description.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+GetFontObj(HDC hdc, LOGFONT *plf)
+{
+    Tcl_Obj *resObj;
+    int len = 0, pt = 0;
+    
+    resObj = Tcl_NewListObj(0, NULL);
+    Tcl_ListObjAppendElement(NULL, resObj,
+	Tcl_NewStringObj(plf->lfFaceName, -1));
+    pt = -MulDiv(plf->lfHeight, 72, GetDeviceCaps(hdc, LOGPIXELSY));
+    Tcl_ListObjAppendElement(NULL, resObj, Tcl_NewIntObj(pt));
+    if (plf->lfWeight >= 700) {
+	Tcl_ListObjAppendElement(NULL, resObj,
+	    Tcl_NewStringObj("bold", -1));
+    }
+    if (plf->lfItalic) {
+	Tcl_ListObjAppendElement(NULL, resObj,
+	    Tcl_NewStringObj("italic", -1));
+    }
+    if (plf->lfUnderline) {
+	Tcl_ListObjAppendElement(NULL, resObj,
+	    Tcl_NewStringObj("underline", -1));
+    }
+    if (plf->lfStrikeOut) {
+	Tcl_ListObjAppendElement(NULL, resObj,
+	    Tcl_NewStringObj("overstrike", -1));
+    }
+    return resObj;
+}
+
+static void
+ApplyLogfont(Tcl_Interp *interp, Tcl_Obj *cmdObj, HDC hdc, LOGFONT *logfontPtr)
+{
+    int objc;
+    Tcl_Obj **objv, **tmpv;
+    Tcl_ListObjGetElements(NULL, cmdObj, &objc, &objv);
+    tmpv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 2));
+    memcpy(tmpv, objv, sizeof(Tcl_Obj *) * objc);
+    tmpv[objc] = GetFontObj(hdc, logfontPtr);
+    BackgroundEvalObjv(interp, objc+1, tmpv, TCL_EVAL_GLOBAL);
+    ckfree((char *)tmpv);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * HookProc --
+ *
+ *	Font selection hook. If the user selects Apply on the dialog, we
+ *	call the applyProc script with the currently selected font as 
+ *	arguments.
+ *
+ * ----------------------------------------------------------------------
+ */
+   
+typedef struct HookData {
+    Tcl_Interp *interp;
+    Tcl_Obj *titleObj;
+    Tcl_Obj *cmdObj;
+    Tcl_Obj *parentObj;
+    Tcl_Obj *fontObj;
+    HWND hwnd;
+} HookData;
+
+static UINT_PTR CALLBACK
+HookProc(HWND hwndDlg, UINT msg, WPARAM wParam, LPARAM lParam)
+{
+    CHOOSEFONT *pcf = (CHOOSEFONT *)lParam;
+    static HookData *phd = NULL;
+    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+	    Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+    
+    if (WM_INITDIALOG == msg && lParam != 0) {
+	phd = (HookData *)pcf->lCustData;
+	phd->hwnd = hwndDlg;
+	if (tsdPtr->debugFlag) {
+	    tsdPtr->debugInterp = (Tcl_Interp *) phd->interp;
+	    Tcl_DoWhenIdle(SetTkDialog, (ClientData) hwndDlg);
+	}
+	if (phd->titleObj != NULL) {
+	    int len = 0;
+	    Tcl_UniChar *wsz = 
+		Tcl_GetUnicodeFromObj(phd->titleObj, &len);
+	    if (len > 0) {
+		SetWindowTextW(hwndDlg, wsz);
+		return 1;
+	    }
+	}
+    }
+    
+    /*
+     * Handle apply button by calling the provided command script as
+     * a background evaluation (ie: errors dont come back here).
+     */
+    if (WM_COMMAND == msg && LOWORD(wParam) == 1026) {
+	LOGFONT lf = {0};
+	int iPt = 0;
+	HDC hdc = GetDC(hwndDlg);
+	SendMessage(hwndDlg, WM_CHOOSEFONT_GETLOGFONT, 0, (LPARAM)&lf);
+	if (phd && phd->cmdObj) {
+	    ApplyLogfont(phd->interp, phd->cmdObj, hdc, &lf);
+	}
+	return 1;
+    }
+    return 0; /* pass on for default processing */
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tk_ChooseFontObjCmd --
+ *
+ *	This function implements the font selection dialog for the Windows
+ *	platform. See the user documentation for what it does.
+ *
+ * Results:
+ *	Selected font description or empty string if cancelled.
+ *
+ * Side effects:
+ *	Modal dialog is displayed, may run script if 'Apply' is chosen.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+ChoosefontConfigureCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *CONST objv[])
+{
+    Tk_Window tkwin = (Tk_Window)clientData;
+    HookData *hdPtr = NULL;
+    int i;
+    static const char *optionStrings[] = {
+	"-parent", "-title", "-font", "-command", NULL
+    };
+    enum options {
+	ChooseFontParent, ChooseFontTitle, ChooseFontFont, ChooseFontCmd
+    };
+
+    hdPtr = Tcl_GetAssocData(interp, "::tk::choosefont", NULL);
+    for (i = 1; i < objc; i += 2) {
+	int optionIndex;
+	if (Tcl_GetIndexFromObj(interp, objv[i], optionStrings,
+		"option", 0, &optionIndex) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (i + 1 == objc) {
+	    Tcl_AppendResult(interp, "value for \"",
+		Tcl_GetString(objv[i]), "\" missing", NULL);
+	    return TCL_ERROR;
+	}
+	switch (optionIndex) {
+	    case ChooseFontParent: {
+		Tk_Window parent = Tk_NameToWindow(interp,
+		    Tcl_GetString(objv[i+1]), tkwin);
+		if (parent == None) {
+		    return TCL_ERROR;
+		}
+		if (hdPtr->parentObj) {
+		    Tcl_DecrRefCount(hdPtr->parentObj);
+		}
+		hdPtr->parentObj = objv[i+1];
+		if (Tcl_IsShared(hdPtr->parentObj)) {
+		    hdPtr->parentObj = Tcl_DuplicateObj(hdPtr->parentObj);
+		}
+		Tcl_IncrRefCount(hdPtr->parentObj);
+		break;
+	    }
+	    case ChooseFontTitle: {
+		if (hdPtr->titleObj) {
+		    Tcl_DecrRefCount(hdPtr->titleObj);
+		}
+		hdPtr->titleObj = objv[i+1];
+		if (Tcl_IsShared(hdPtr->titleObj)) {
+		    hdPtr->titleObj = Tcl_DuplicateObj(hdPtr->titleObj);
+		}
+		Tcl_IncrRefCount(hdPtr->titleObj);
+		break;
+	    }
+	    case ChooseFontFont: {
+		if (hdPtr->fontObj) {
+		    Tcl_DecrRefCount(hdPtr->fontObj);
+		}
+		hdPtr->fontObj = objv[i+1];
+		if (Tcl_IsShared(hdPtr->fontObj)) {
+		    hdPtr->fontObj = Tcl_DuplicateObj(hdPtr->fontObj);
+		}
+		Tcl_IncrRefCount(hdPtr->fontObj);
+		break;
+	    }
+	    case ChooseFontCmd: {
+		if (hdPtr->cmdObj) {
+		    Tcl_DecrRefCount(hdPtr->cmdObj);
+		}
+		hdPtr->cmdObj = objv[i+1];
+		if (Tcl_IsShared(hdPtr->cmdObj)) {
+		    hdPtr->cmdObj = Tcl_DuplicateObj(hdPtr->cmdObj);
+		}
+		Tcl_IncrRefCount(hdPtr->cmdObj);
+		break;
+	    }
+	}
+    }
+    return TCL_OK;
+}
+
+static int
+ChoosefontShowCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *CONST objv[])
+{
+    Tk_Window tkwin, parent;
+    CHOOSEFONT cf;
+    LOGFONT lf;
+    HDC hdc;
+    HookData *hdPtr;
+    int r = TCL_OK, oldMode = 0;
+    Tcl_Obj *resObj = NULL;
+
+    hdPtr = Tcl_GetAssocData(interp, "::tk::choosefont", NULL);
+
+    tkwin = parent = (Tk_Window) clientData;
+    if (hdPtr->parentObj) {
+	parent = Tk_NameToWindow(interp, Tcl_GetString(hdPtr->parentObj), tkwin);
+	if (parent == None) {
+	    return TCL_ERROR;
+	}
+    }
+
+    Tk_MakeWindowExist(parent);
+
+    ZeroMemory(&cf, sizeof(CHOOSEFONT));
+    ZeroMemory(&lf, sizeof(LOGFONT));
+    lf.lfCharSet = DEFAULT_CHARSET;
+    cf.lStructSize = sizeof(CHOOSEFONT);
+    cf.hwndOwner = Tk_GetHWND(Tk_WindowId(parent));
+    cf.lpLogFont = &lf;
+    cf.nFontType = SCREEN_FONTTYPE;
+    cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_ENABLEHOOK;
+    cf.rgbColors = RGB(0,0,0);
+    cf.lpfnHook = HookProc;
+    cf.lCustData = (INT_PTR)hdPtr;
+    hdPtr->interp = interp;
+    hdc = GetDC(cf.hwndOwner);
+
+    if (hdPtr->fontObj != NULL) {
+	TkFont *fontPtr;
+	Tk_Font f = Tk_AllocFontFromObj(interp, tkwin, hdPtr->fontObj);
+	if (f == NULL) {
+	    return TCL_ERROR;
+	}
+	fontPtr = (TkFont *)f;
+	cf.Flags |= CF_INITTOLOGFONTSTRUCT;
+	strncpy(lf.lfFaceName, Tk_GetUid(fontPtr->fa.family), LF_FACESIZE-1);
+	lf.lfFaceName[LF_FACESIZE-1] = 0;
+	lf.lfHeight = -MulDiv(TkFontGetPoints(tkwin, fontPtr->fa.size),
+	    GetDeviceCaps(hdc, LOGPIXELSY), 72);
+	if (fontPtr->fa.weight == TK_FW_BOLD) lf.lfWeight = FW_BOLD;
+	if (fontPtr->fa.slant != TK_FS_ROMAN) lf.lfItalic = TRUE;
+	if (fontPtr->fa.underline) lf.lfUnderline = TRUE;
+	if (fontPtr->fa.overstrike) lf.lfStrikeOut = TRUE;
+	Tk_FreeFont(f);
+    }
+        
+    if (TCL_OK == r && hdPtr->cmdObj != NULL) {
+	int len = 0;
+	r = Tcl_ListObjLength(interp, hdPtr->cmdObj, &len);
+	if (len > 0) cf.Flags |= CF_APPLY;
+    }
+
+    if (TCL_OK == r) {
+	oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
+	if (ChooseFont(&cf) && hdPtr->cmdObj) {
+	    ApplyLogfont(hdPtr->interp, hdPtr->cmdObj, hdc, &lf);
+	}
+	Tcl_SetServiceMode(oldMode);
+	hdPtr->hwnd = NULL;
+	EnableWindow(cf.hwndOwner, 1);
+    }
+
+    ReleaseDC(cf.hwndOwner, hdc);
+        
+    return r;
+}
+
+static int
+ChoosefontHideCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *CONST objv[])
+{
+    HookData *hdPtr = Tcl_GetAssocData(interp, "::tk::choosefont", NULL);
+    if (hdPtr->hwnd && IsWindow(hdPtr->hwnd)) {
+	EndDialog(hdPtr->hwnd, 0);
+    }
+    return TCL_OK;
+}
+
+static void
+DeleteHookData(ClientData clientData, Tcl_Interp *interp)
+{
+    HookData *hdPtr = clientData;
+    if (hdPtr->parentObj)
+	Tcl_DecrRefCount(hdPtr->parentObj);
+    if (hdPtr->fontObj)
+	Tcl_DecrRefCount(hdPtr->fontObj);
+    if (hdPtr->titleObj)
+	Tcl_DecrRefCount(hdPtr->titleObj);
+    if (hdPtr->cmdObj)
+	Tcl_DecrRefCount(hdPtr->cmdObj);
+    ckfree((char *)hdPtr);
+}
+
+static const TkEnsemble choosefontEnsemble[] = {
+    { "configure", ChoosefontConfigureCmd, NULL },
+    { "show", ChoosefontShowCmd, NULL },
+    { "hide", ChoosefontHideCmd, NULL },
+};
+
+int
+TkChoosefontInit(Tcl_Interp *interp, ClientData clientData)
+{
+    HookData *hdPtr = NULL;
+    hdPtr = (HookData *)ckalloc(sizeof(HookData));
+    memset(hdPtr, 0, sizeof(HookData));
+    Tcl_SetAssocData(interp, "::tk::choosefont", DeleteHookData, hdPtr);
+    TkMakeEnsemble(interp, "::tk", "choosefont", 
+	clientData, choosefontEnsemble);
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
