TIP #324 IMPLEMENTATION

FossilOrigin-Name: 7946dc2242dda6d99b301092e8559037911722fe
author: das <das@noemail.net> 2008-12-10 05:02:38 (GMT)
committer: das <das@noemail.net> 2008-12-10 05:02:38 (GMT)
commit: 0be6d3101da9d47238f246b7d4f522705a04779b (patch)
tree: 2f061501366a0706fb1db4d2cd36d5c490ace9f6
parent: 4c95ed16d07fab4fa052d2120afcae6c21f1a899 (diff)
download: tk-0be6d3101da9d47238f246b7d4f522705a04779b.zip
tk-0be6d3101da9d47238f246b7d4f522705a04779b.tar.gz
tk-0be6d3101da9d47238f246b7d4f522705a04779b.tar.bz2
25 files changed, 2459 insertions, 74 deletions
diff --git a/ChangeLog b/ChangeLog
index 9d0deb3..06375f1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,39 @@
 2008-12-10  Daniel Steffen  <das@users.sourceforge.net>
 
-	* generic/tkInt.h:	Turn [tk] into an ensemble (thoyts, steffen)
-	* generic/tkBusy.c:
+	TIP #324 IMPLEMENTATION
+
+	* generic/tkCmds.c:		Implementation of [tk fontchooser]
+	* generic/tkInt.h:		as a Ttk dialog for X11 and as a native
+	* library/fontchooser.tcl:	platform dialog on Mac OS X & Windows.
+	* library/tclIndex:		(thoyts, vetter, robert, steffen)
+	* library/msgs/de.msg:
+	* library/msgs/en.msg:
+	* macosx/tkMacOSXCarbonEvents.c:
+	* macosx/tkMacOSXDialog.c:
+	* macosx/tkMacOSXEvent.c:
+	* macosx/tkMacOSXEvent.h:
+	* macosx/tkMacOSXFont.c:
+	* macosx/tkMacOSXFont.h:
+	* macosx/Wish.xcodeproj/project.pbxproj:
+	* win/tkWinDialog.c:
+	* win/tkWinInt.h:
+	* win/tkWinTest.c:
+	* win/tkWinX.c:
+	* tests/fontchooser.test:
+	* tests/winDialog.test:
+	* doc/fontchooser.n:
+	* doc/tk.n:
+
+	* library/console.tcl:		Let user select console font via
+					[tk fontchooser].
+	* library/demos/text.tcl:	Add [tk fontchooser] demo.
+
+	* generic/tkUtil.c:		Add TkBackgroundEvalObjv() and
+					TkSendVirtualEvent() utility functions
+					(used by TIP #324 code).
+
+	* generic/tkInt.h:		Turn [tk] into an ensemble.
+	* generic/tkBusy.c:		(thoyts, steffen)
 	* generic/tkCmds.c:
 	* generic/tkWindow.c:
 
diff --git a/doc/fontchooser.n b/doc/fontchooser.n
new file mode 100644
index 0000000..6e3a766
--- /dev/null
+++ b/doc/fontchooser.n
@@ -0,0 +1,183 @@
+'\"
+'\" Copyright (c) 2008 Daniel A. Steffen <das@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: fontchooser.n,v 1.1 2008/12/10 05:02:40 das Exp $
+'\" 
+.so man.macros
+.TH fontchooser n "" Tk "Tk Built-In Commands"
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+fontchooser \- control font selection dialog
+.SH SYNOPSIS
+\fBtk fontchooser\fR \fBconfigure\fR ?\fI\-option value \-option value ...\fR?
+.sp
+\fBtk fontchooser\fR \fBshow\fR
+.sp
+\fBtk fontchooser\fR \fBhide\fR
+.BE
+.SH DESCRIPTION
+.PP
+The \fBtk fontchooser\fR command controls the Tk font selection dialog. It uses
+the native platform font selection dialog where available, or a dialog
+implemented in Tcl otherwise.
+.PP
+Unlike most of the other Tk dialog commands, \fBtk fontchooser\fR does not
+return an immediate result, as on some platforms (Mac OS X) the standard font
+dialog is modeless while on others (Windows) it is modal. To accommodate this
+difference, all user interaction with the dialog will be communicated to the
+caller via callbacks or virtual events.
+.PP
+The \fBtk fontchooser\fR command can have one of the following forms:
+.TP
+\fBtk fontchooser\fR \fBconfigure \fR?\fI\-option value \-option value ...\fR?
+.
+Set or query one or more of the configurations options below (analogous to Tk
+widget configuration).
+.TP
+\fBtk fontchooser\fR \fBshow\fR
+.
+Show the font selection dialog. Depending on the platform, may return
+immediately or only once the dialog has been withdrawn.
+.TP
+\fBtk fontchooser\fR \fBhide\fR
+.
+Hide the font selection dialog if it is visible and cause any pending
+\fBtk fontchooser\fR \fBshow\fR command to return.
+.PP
+.SH "CONFIGURATION OPTIONS"
+.TP
+\fB\-parent\fR
+Specifies/returns the logical parent window of the font selection dialog
+(similar to the \fB\-parent\fR option to other dialogs). The font selection
+dialog is hidden if it is visible when the parent window is destroyed.
+.TP
+\fB\-title\fR
+Specifies/returns the title of the dialog. Has no effect on platforms where the
+font selection dialog does not support titles.
+.TP
+\fB\-font\fR
+Specifies/returns the font that is currently selected in the dialog if it is
+visible, or that will be initially selected when the dialog is shown (if
+supported by the platform). Can be set to the empty string to indicate that no
+font should be selected. Fonts can be specified in any form given by the "FONT
+DESCRIPTION" section in the \fBfont\fR manual page.
+.TP
+\fB\-command\fR
+Specifies/returns the command prefix to be called when a font selection has
+been made by the user. The command prefix is evaluated at the global level
+after having the specification of the selected font appended. On platforms
+where the font selection dialog offers the user control of further font
+attributes (such as color), additional key/value pairs may be appended before
+evaluation. Can be set to the empty string to indicate that no callback should
+be invoked. Fonts are specified by a list of form [3] of the "FONT DESCRIPTION"
+section in the \fBfont\fR manual page (i.e. a list of the form
+\fI{family size style ?style ...?}\fR).
+.TP
+\fB\-visible\fR
+Read-only option that returns a boolean indicating whether the font selection
+dialog is currently visible. Attempting to set this option results in an error.
+
+.PP
+.SH "VIRTUAL EVENTS"
+.TP
+\fB<<TkFontchooserVisibility>>\fR
+Sent to the dialog parent whenever the visibility of the font selection dialog
+changes, both as a result of user action (e.g. disposing of the dialog via
+OK/Cancel button or close box) and of the \fBtk fontchooser\fR
+\fBshow\fR/\fBhide\fR commands being called. Binding scripts can determine the
+current visibility of the dialog by querying the \fB\-visible\fR configuration
+option.
+.TP
+\fB<<TkFontchooserFontChanged>>\fR
+Sent to the dialog parent whenever the font selection dialog is visible and the
+selected font changes, both as a result of user action and of the \fB\-font\fR
+configuration option being set. Binding scripts can determine the currently
+selected font by querying the \fB\-font\fR configuration option.
+.PP
+.SH NOTES
+.PP
+Callers should not expect a result from \fBtk fontchooser\fR \fBshow\fR and may
+not assume that the dialog has been withdrawn or closed when the command
+returns. All user interaction with the dialog is communicated to the caller via
+the \fB\-command\fR callback and the \fB<<TkFontchooser*>>\fR virtual events.
+It is implementation dependent which exact user actions result in the callback
+being called resp. the virtual events being sent. Where an Apply or OK button
+is present in the dialog, that button will trigger the \fB\-command\fR callback
+and \fB<<TkFontchooserFontChanged>>\fR virtual event. On some implementations
+other user actions may also have that effect; on Mac OS X for instance, the
+standard font selection dialog immediately reflects all user choices to the
+caller.
+.PP
+In the presence of multiple widgets intended to be influenced by the font
+selection dialog, care needs to be taken to correctly handle focus changes: the
+font selected in the dialog should always match the current font of the widget
+with the focus, and the \fB\-command\fR callback should only act on the widget
+with the focus. The recommended practice is to set font dialog \fB\-font\fR and
+\fB\-command\fR configuration options in per\-widget \fB<FocusIn>\fR handlers
+(and if necessary to unset them \- i.e. set to the empty string \- in
+corresponding \fB<FocusOut>\fR handlers). This is particularly important for
+implementors of library code using the font selection dialog, to avoid
+conflicting with application code that may also want to use the dialog.
+.PP
+Because the font selection dialog is application-global, in the presence of
+multiple interpreters calling \fBtk fontchooser\fR, only the \fB\-command\fR
+callback set by the interpreter that most recently called \fBtk fontchooser\fR
+\fBconfigure\fR or \fBtk fontchooser\fR \fBshow\fR will be invoked in response
+to user action and only the \fB\-parent\fR set by that interpreter will receive
+\fB<<TkFontchooser*>>\fR virtual events.
+.PP
+The font dialog implementation may only store (and return) \fBfont\fR
+\fBactual\fR data as the value of the \fB\-font\fR configuration option. This
+can be an issue when \fB\-font\fR is set to a named font, if that font is
+subsequently changed, the font dialog \fB\-font\fR option needs to be set again
+to ensure its selected font matches the new value of the named font.
+.PP
+.SH EXAMPLE
+.PP
+.CS
+proc fontchooserDemo {} {
+    wm title . "Font Chooser Demo"
+    \fBtk fontchooser\fR \fBconfigure\fR \-parent .
+    button .b \-command fontchooserToggle \-takefocus 0
+    fontchooserVisibility .b
+    bind . \fB<<TkFontchooserVisibility>>\fR \\
+            [list fontchooserVisibility .b]
+    foreach w {.t1 .t2} {
+        text $w \-width 20 \-height 4 \-borderwidth 1 \-relief solid
+        bind $w <FocusIn> [list fontchooserFocus $w]
+        $w insert end "Text Widget $w"
+    }
+    .t1 configure \-font {Courier 14}
+    .t2 configure \-font {Times 16}
+    pack .b .t1 .t2; focus .t1
+}
+proc fontchooserToggle {} {
+    \fBtk fontchooser\fR [expr {
+            [\fBtk fontchooser\fR \fBconfigure\fR \-visible] ?
+            "\fBhide\fR" : "\fBshow\fR"}]
+}
+proc fontchooserVisibility {w} {
+    $w configure \-text [expr {
+            [\fBtk fontchooser\fR \fBconfigure\fR \-visible] ?
+            "Hide Font Dialog" : "Show Font Dialog"}]
+}
+proc fontchooserFocus {w} {
+    \fBtk fontchooser\fR \fBconfigure\fR \-font [$w cget \-font] \\
+            \-command [list fontchooserFontSelection $w]
+}
+proc fontchooserFontSelection {w font args} {
+    $w configure \-font [font actual $font]
+}
+fontchooserDemo
+.CE
+.SH "SEE ALSO"
+font(n), tk(n)
+.SH KEYWORDS
+dialog, font, font selection, font chooser, font panel
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/doc/tk.n b/doc/tk.n
index ece777e..c762946 100644
--- a/doc/tk.n
+++ b/doc/tk.n
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: tk.n,v 1.20 2008/10/18 14:22:21 dkf Exp $
+'\" RCS: @(#) $Id: tk.n,v 1.21 2008/12/10 05:02:40 das Exp $
 '\" 
 .so man.macros
 .TH tk n 8.4 Tk "Tk Built-In Commands"
@@ -66,6 +66,28 @@ format.  \fI\-x\fR and \fI\-y\fR represent window-relative coordinates, and
 \fI\-height\fR is the height of the current cursor location, or the height
 of the specified \fIwindow\fR if none is given.
 .TP
+\fBtk inactive \fR?\fB\-displayof \fIwindow\fR? ?\fBreset\fR?
+.
+Returns a positive integer, the number of milliseconds since the last
+time the user interacted with the system. If the \fB\-displayof\fR
+option is given then the return value refers to the display of
+\fIwindow\fR; otherwise it refers to the display of the application's
+main window.
+.RS
+.PP
+\fBtk inactive\fR will return \-1, if querying the user inactive time
+is not supported by the system, and in safe interpreters.
+.PP
+If the literal string \fBreset\fR is given as an additional argument,
+the timer is reset and an empty string is returned. Resetting the
+inactivity time is forbidden in safe interpreters and will throw and
+error if tried.
+.RE
+.TP
+\fBtk fontchooser \fIsubcommand\fR ...
+Controls the Tk font selection dialog. For more details see the
+\fBfontchooser\fR manual page.
+.TP
 \fBtk scaling \fR?\fB\-displayof \fIwindow\fR? ?\fInumber\fR?
 .
 Sets and queries the current scaling factor used by Tk to convert between
@@ -91,24 +113,6 @@ is undefined whether existing widgets will resize themselves dynamically to
 accommodate the new scaling factor.
 .RE
 .TP
-\fBtk inactive \fR?\fB\-displayof \fIwindow\fR? ?\fBreset\fR?
-.
-Returns a positive integer, the number of milliseconds since the last
-time the user interacted with the system. If the \fB\-displayof\fR
-option is given then the return value refers to the display of
-\fIwindow\fR; otherwise it refers to the display of the application's
-main window.
-.RS
-.PP
-\fBtk inactive\fR will return \-1, if querying the user inactive time
-is not supported by the system, and in safe interpreters.
-.PP
-If the literal string \fBreset\fR is given as an additional argument,
-the timer is reset and an empty string is returned. Resetting the
-inactivity time is forbidden in safe interpreters and will throw and
-error if tried.
-.RE
-.TP
 \fBtk useinputmethods \fR?\fB\-displayof \fIwindow\fR? ?\fIboolean\fR?
 .
 Sets and queries the state of whether Tk should use XIM (X Input Methods)
@@ -125,7 +129,7 @@ Returns the current Tk windowing system, one of
 \fBx11\fR (X11-based), \fBwin32\fR (MS Windows),
 or \fBaqua\fR (Mac OS X Aqua).
 .SH "SEE ALSO"
-busy(n), send(n), winfo(n)
+busy(n), fontchooser(n), send(n), winfo(n)
 .SH KEYWORDS
 application name, send
 '\" Local Variables:
diff --git a/generic/tkCmds.c b/generic/tkCmds.c
index 49d1f38..21bd8d4 100644
--- a/generic/tkCmds.c
+++ b/generic/tkCmds.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkCmds.c,v 1.48 2008/12/10 00:34:51 das Exp $
+ * RCS: @(#) $Id: tkCmds.c,v 1.49 2008/12/10 05:02:40 das Exp $
  */
 
 #include "tkInt.h"
@@ -51,6 +51,12 @@ static int		WindowingsystemCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
 
+#if defined(__WIN32__) || defined(MAC_OSX_TK)
+MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[];
+#else
+#define tkFontchooserEnsemble NULL
+#endif
+
 /*
  * Table of tk subcommand names and implementations.
  */
@@ -63,6 +69,7 @@ static const TkEnsemble tkCmdMap[] = {
     {"scaling",		ScalingCmd },
     {"useinputmethods",	UseinputmethodsCmd },
     {"windowingsystem",	WindowingsystemCmd },
+    {"fontchooser",	NULL, tkFontchooserEnsemble},
     {NULL}
 };
 
@@ -635,6 +642,9 @@ int
 TkInitTkCmd(Tcl_Interp *interp, ClientData clientData)
 {
     TkMakeEnsemble(interp, "::", "tk", clientData, tkCmdMap);
+#if defined(__WIN32__) || defined(MAC_OSX_TK)
+    TkInitFontchooser(interp, clientData);
+#endif
     return TCL_OK;
 }
 
diff --git a/generic/tkInt.h b/generic/tkInt.h
index 7131bb7..214b428 100644
--- a/generic/tkInt.h
+++ b/generic/tkInt.h
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: $Id: tkInt.h,v 1.97 2008/12/10 00:34:51 das Exp $
+ * RCS: $Id: tkInt.h,v 1.98 2008/12/10 05:02:51 das Exp $
  */
 
 #ifndef _TKINT
@@ -1040,9 +1040,6 @@ MODULE_SCOPE int	Tk_ChooseColorObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tk_ChooseDirectoryObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
-MODULE_SCOPE int	Tk_ChooseFontObjCmd(ClientData clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tk_DestroyObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -1251,7 +1248,6 @@ MODULE_SCOPE void	TkpMakeTransparentWindowExist(Tk_Window tkwin,
 MODULE_SCOPE void	TkpCreateBusy(Tk_FakeWin *winPtr, Tk_Window tkRef,
 			    Window *parentPtr, Tk_Window tkParent,
 			    TkBusy busy);
-
 MODULE_SCOPE void	TkDrawAngledTextLayout(Display *display,
 			    Drawable drawable, GC gc, Tk_TextLayout layout,
 			    int x, int y, double angle, int firstChar,
@@ -1264,11 +1260,16 @@ MODULE_SCOPE void	TkUnderlineAngledTextLayout(Display *display,
 			    int x, int y, double angle, int underline);
 MODULE_SCOPE int	TkIntersectAngledTextLayout(Tk_TextLayout layout,
 			    int x,int y, int width, int height, double angle);
+MODULE_SCOPE int	TkBackgroundEvalObjv(Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const *objv, int flags);
+MODULE_SCOPE void	TkSendVirtualEvent(Tk_Window tgtWin, const char *eventName);
 MODULE_SCOPE Tcl_Command TkMakeEnsemble(Tcl_Interp *interp,
 			    const char *namespace, const char *name,
 			    ClientData clientData, const TkEnsemble *map);
 MODULE_SCOPE int	TkInitTkCmd(Tcl_Interp *interp,
 			    ClientData clientData);
+MODULE_SCOPE int	TkInitFontchooser(Tcl_Interp *interp,
+			    ClientData clientData);
 
 /*
  * Unsupported commands.
diff --git a/generic/tkUtil.c b/generic/tkUtil.c
index 8cfaf9a..5218740 100644
--- a/generic/tkUtil.c
+++ b/generic/tkUtil.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkUtil.c,v 1.26 2008/12/10 04:27:45 das Exp $
+ * RCS: @(#) $Id: tkUtil.c,v 1.27 2008/12/10 05:02:51 das Exp $
  */
 
 #include "tkInt.h"
@@ -978,6 +978,89 @@ TkFindStateNumObj(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TkBackgroundEvalObjv --
+ *
+ *	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.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TkBackgroundEvalObjv(
+    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;
+}
+
+/*
  *----------------------------------------------------------------------
  *
  * TkMakeEnsemble --
@@ -1060,6 +1143,36 @@ TkMakeEnsemble(
     Tcl_DStringFree(&ds);
     return ensemble;
 }
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkSendVirtualEvent --
+ *
+ * 	Send a virtual event notification to the specified target window.
+ * 	Equivalent to "event generate $target <<$eventName>>"
+ *
+ * 	Note that we use Tk_QueueWindowEvent, not Tk_HandleEvent,
+ * 	so this routine does not reenter the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TkSendVirtualEvent(Tk_Window target, const char *eventName)
+{
+    XEvent event;
+
+    memset(&event, 0, sizeof(event));
+    event.xany.type = VirtualEvent;
+    event.xany.serial = NextRequest(Tk_Display(target));
+    event.xany.send_event = False;
+    event.xany.window = Tk_WindowId(target);
+    event.xany.display = Tk_Display(target);
+    ((XVirtualEvent *) &event)->name = Tk_GetUid(eventName);
+
+    Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL);
+}
 /*
  * Local Variables:
  * mode: c
diff --git a/library/console.tcl b/library/console.tcl
index cc38ca5..2fddfe3 100644
--- a/library/console.tcl
+++ b/library/console.tcl
@@ -4,11 +4,11 @@
 # can be used by non-unix systems that do not have built-in support
 # for shells.
 #
-# RCS: @(#) $Id: console.tcl,v 1.38 2008/05/13 13:25:18 patthoyts Exp $
+# RCS: @(#) $Id: console.tcl,v 1.39 2008/12/10 05:02:51 das Exp $
 #
 # Copyright (c) 1995-1997 Sun Microsystems, Inc.
 # Copyright (c) 1998-2000 Ajuba Solutions.
-# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+# Copyright (c) 2007-2008 Daniel A. Steffen <das@users.sourceforge.net>
 #
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -22,11 +22,10 @@ namespace eval ::tk::console {
     variable magicKeys   1   ; # enable brace matching and proc/var recognition
     variable maxLines    600 ; # maximum # of lines buffered in console
     variable showMatches 1   ; # show multiple expand matches
-
+    variable useFontchooser [llength [info command ::tk::fontchooser]]
     variable inPlugin [info exists embed_args]
     variable defaultPrompt   ; # default prompt if tcl_prompt1 isn't used
 
-
     if {$inPlugin} {
 	set defaultPrompt {subst {[history nextid] % }}
     } else {
@@ -98,6 +97,24 @@ proc ::tk::ConsoleInit {} {
     }
 
     AmpMenuArgs .menubar.edit add separator
+    if {$::tk::console::useFontchooser} {
+        if {[tk windowingsystem] eq "aqua"} {
+            .menubar.edit add command -label tk_choose_font_marker
+            set index [.menubar.edit index tk_choose_font_marker]
+            .menubar.edit entryconfigure $index \
+                -label [mc "Show Fonts"]\
+                -accelerator "$mod-T"\
+                -command [list ::tk::console::FontchooserToggle]
+            bind Console <<TkFontchooserVisibility>> \
+                [list ::tk::console::FontchooserVisibility $index]
+	    ::tk::console::FontchooserVisibility $index
+        } else {
+            AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
+                -command [list ::tk::console::FontchooserToggle]
+        }
+	bind Console <FocusIn>  [list ::tk::console::FontchooserFocus %W 1]
+	bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0]
+    }
     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"] \
@@ -396,6 +413,9 @@ proc ::tk::ConsoleBind {w} {
 	    event add $ev $key
 	    bind Console $key {}
 	}
+	if {$::tk::console::useFontchooser} {
+	    bind Console <Command-Key-t> [list ::tk::console::FontchooserToggle]
+	}
     }
     bind Console <<Console_Expand>> {
 	if {[%W compare insert > promptEnd]} {
@@ -557,6 +577,9 @@ proc ::tk::ConsoleBind {w} {
         if {$size < 0} {set sign -1} else {set sign 1}
         set size [expr {(abs($size) + 1) * $sign}]
         font configure TkConsoleFont -size $size
+	if {$::tk::console::useFontchooser} {
+	    tk fontchooser configure -font TkConsoleFont
+	}
     }
     bind Console <<Console_FontSizeDecr>> {
         set size [font configure TkConsoleFont -size]
@@ -564,6 +587,9 @@ proc ::tk::ConsoleBind {w} {
         if {$size < 0} {set sign -1} else {set sign 1}
         set size [expr {(abs($size) - 1) * $sign}]
         font configure TkConsoleFont -size $size
+	if {$::tk::console::useFontchooser} {
+	    tk fontchooser configure -font TkConsoleFont
+	}
     }
 
     ##
@@ -669,6 +695,35 @@ Tcl $::tcl_patchLevel
 Tk $::tk_patchLevel"
 }
 
+# ::tk::console::Fontchooser* --
+# 	Let the user select the console font (TIP 324).
+
+proc ::tk::console::FontchooserToggle {} {
+    if {[tk fontchooser configure -visible]} {
+	tk fontchooser hide
+    } else {
+	tk fontchooser show
+    }
+}
+proc ::tk::console::FontchooserVisibility {index} {
+    if {[tk fontchooser configure -visible]} {
+	.menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"]
+    } else {
+	.menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"]
+    }
+}
+proc ::tk::console::FontchooserFocus {w isFocusIn} {
+    if {$isFocusIn} {
+	tk fontchooser configure -parent $w -font TkConsoleFont \
+		-command [namespace code [list FontchooserApply]]
+    } else {
+	tk fontchooser configure -parent $w -font {} -command {}
+    }
+}
+proc ::tk::console::FontchooserApply {font args} {
+    catch {font configure TkConsoleFont {*}[font actual $font]}
+}
+
 # ::tk::console::TagProc --
 #
 # Tags a procedure in the console if it's recognized
diff --git a/library/demos/text.tcl b/library/demos/text.tcl
index 6f25273..5b8341d 100644
--- a/library/demos/text.tcl
+++ b/library/demos/text.tcl
@@ -3,7 +3,7 @@
 # This demonstration script creates a text widget that describes
 # the basic editing functions.
 #
-# RCS: @(#) $Id: text.tcl,v 1.8 2007/12/13 15:27:07 dgp Exp $
+# RCS: @(#) $Id: text.tcl,v 1.9 2008/12/10 05:02:51 das Exp $
 
 if {![info exists widgetDemo]} {
     error "This script should be run from the \"widget\" demo."
@@ -19,7 +19,8 @@ wm iconname $w "text"
 positionWindow $w
 
 ## See Code / Dismiss buttons
-set btns [addSeeDismiss $w.buttons $w]
+set btns [addSeeDismiss $w.buttons $w {} \
+	{ttk::button $w.buttons.fontchooser -command fontchooserToggle}]
 pack $btns -side bottom -fill x
 
 text $w.text -yscrollcommand [list $w.scroll set] -setgrid 1 \
@@ -27,6 +28,30 @@ text $w.text -yscrollcommand [list $w.scroll set] -setgrid 1 \
 scrollbar $w.scroll -command [list $w.text yview]
 pack $w.scroll -side right -fill y
 pack $w.text -expand yes -fill both
+
+# TIP 324 Demo: [tk fontchooser]
+proc fontchooserToggle {} {
+    tk fontchooser [expr {[tk fontchooser configure -visible] ?
+            "hide" : "show"}]
+}
+proc fontchooserVisibility {w} {
+    $w configure -text [expr {[tk fontchooser configure -visible] ?
+            "Hide Font Dialog" : "Show Font Dialog"}]
+}
+proc fontchooserFocus {w} {
+    tk fontchooser configure -font [$w cget -font] \
+	    -command [list fontchooserFontSel $w]
+}
+proc fontchooserFontSel {w font args} {
+    $w configure -font [font actual $font]
+}
+tk fontchooser configure -parent $w
+bind $w.text <FocusIn> [list fontchooserFocus $w.text]
+fontchooserVisibility $w.buttons.fontchooser
+bind $w <<TkFontchooserVisibility>> [list \
+	fontchooserVisibility $w.buttons.fontchooser]
+focus $w.text
+
 $w.text insert 0.0 \
 {This window is a text widget.  It displays one or more lines of text
 and allows you to edit the text.  Here is a summary of the things you
diff --git a/library/fontchooser.tcl b/library/fontchooser.tcl
new file mode 100644
index 0000000..290eebf
--- /dev/null
+++ b/library/fontchooser.tcl
@@ -0,0 +1,398 @@
+# fontchooser.tcl -
+#
+#	A themeable Tk font selection dialog. See TIP #324.
+#
+# 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: fontchooser.tcl,v 1.1 2008/12/10 05:02:51 das Exp $
+
+namespace eval ::tk::fontchooser {
+    variable S
+
+    set S(W) .__tk__fontchooser
+    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"]
+    set S(-font) {}
+    set S(-command) {}
+
+    # 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 FontchooserFrame {
+        Entry.field -sticky news -border true -children {
+            FontchooserFrame.padding -sticky news
+        }
+    }
+    bind [winfo class .] <<ThemeChanged>> \
+        [list +ttk::style layout FontchooserFrame \
+             [ttk::style layout FontchooserFrame]]
+
+    namespace ensemble create -map {
+        show ::tk::fontchooser::Show
+        hide ::tk::fontchooser::Hide
+        configure ::tk::fontchooser::Configure
+    }
+}
+
+proc ::tk::fontchooser::Show {} {
+    variable S
+    if {![winfo exists $S(W)]} {
+        Create
+        wm transient $S(W) [winfo toplevel $S(-parent)]
+        tk::PlaceWindow $S(W) widget $S(-parent)
+    }
+    wm deiconify $S(W)
+}
+
+proc ::tk::fontchooser::Hide {} {
+    variable S
+    wm withdraw $S(W)
+}
+
+proc ::tk::fontchooser::Configure {args} {
+    variable S
+
+    set specs {
+        {-parent "" "" .}
+        {-title "" "" " "}
+        {-font "" "" ""}
+        {-command "" "" ""}
+    }
+
+    if {[llength $args] == 1 && [string equal [lindex $args 0] "-visible"]} {
+        return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
+    }
+
+    tclParseConfigSpec [namespace which -variable S] $specs "" $args
+    if {$S(-parent) ne "."} {
+	winfo toplevel $S(-parent)
+    }
+    if {[string trim $S(-title)] eq ""} {
+        set S(-title) [::msgcat::mc "Font"]
+    }
+    if {[winfo exists $S(W)] && [lsearch $args -font] != -1} {
+	Init $S(-font)
+	event generate $S(-parent) <<TkFontchooserFontChanged>>
+    }
+}
+
+proc ::tk::fontchooser::Create {} {
+    variable S
+    set windowName __tk__fontchooser
+    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) <Map> [namespace code [list Visibility %W 1]]
+        bind $S(W) <Unmap> [namespace code [list Visibility %W 0]]
+        bind $S(W) <Destroy> [namespace code [list Visibility %W 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
+        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::fontchooser::Done --
+#
+#       Handles teardown of the dialog, calling -command if needed
+#
+# Arguments:
+#       ok              true if user pressed OK
+#
+proc ::tk::::fontchooser::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::fontchooser::Apply --
+#
+#	Call the -command procedure appending the current font
+#	Errors are reported via the background error mechanism
+#
+proc ::tk::fontchooser::Apply {} {
+    variable S
+    if {$S(-command) ne ""} {
+        if {[catch {uplevel #0 $S(-command) [list $S(result)]} err]} {
+            ::bgerror $err
+        }
+    }
+    event generate $S(-parent) <<TkFontchooserFontChanged>>
+}
+
+# ::tk::fontchooser::Init --
+#
+#       Initializes dialog to a default font
+#
+# Arguments:
+#       defaultFont     font to use as the default
+#
+proc ::tk::fontchooser::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::fontchooser::Click --
+#
+#       Handles all button clicks, updating the appropriate widgets
+#
+# Arguments:
+#       who             which widget got pressed
+#
+proc ::tk::fontchooser::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::fontchooser::Tracer --
+#
+#       Handles traces on key variables, updating the appropriate widgets
+#
+# Arguments:
+#       standard trace arguments (not used)
+#
+proc ::tk::fontchooser::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::fontchooser::Update --
+#
+#       Shows a sample of the currently selected font
+#
+proc ::tk::fontchooser::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::fontchooser::Visibility --
+#
+#	Notify the parent when the dialog visibility changes
+#
+proc ::tk::fontchooser::Visibility {w visible} {
+    variable S
+    if {$w eq $S(W)} {
+        event generate $S(-parent) <<TkFontchooserVisibility>>
+    }
+}
+
+# ::tk::fontchooser::ttk_listbox --
+#
+#	Create a properly themed scrolled listbox.
+#	This is exactly right on XP but may need adjusting on other platforms.
+#
+proc ::tk::fontchooser::ttk_slistbox {w args} {
+    set f [ttk::frame $w -style FontchooserFrame -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
+}
diff --git a/library/msgs/de.msg b/library/msgs/de.msg
index 39daf82..aa20340 100644
--- a/library/msgs/de.msg
+++ b/library/msgs/de.msg
@@ -5,6 +5,7 @@ namespace eval ::tk {
     ::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"
diff --git a/library/msgs/en.msg b/library/msgs/en.msg
index b4e51bf..5ad1094 100644
--- a/library/msgs/en.msg
+++ b/library/msgs/en.msg
@@ -3,7 +3,11 @@ namespace eval ::tk {
     ::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 @@ namespace eval ::tk {
     ::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 @@ namespace eval ::tk {
     ::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 @@ namespace eval ::tk {
     ::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"
diff --git a/library/tclIndex b/library/tclIndex
index e7f5b81..df4c046 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -276,3 +276,4 @@ set auto_index(::tk::ListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.
 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::fontchooser) [list source [file join $dir fontchooser.tcl]]
diff --git a/macosx/Wish.xcodeproj/project.pbxproj b/macosx/Wish.xcodeproj/project.pbxproj
index e4b3ece..d3c4f87 100644
--- a/macosx/Wish.xcodeproj/project.pbxproj
+++ b/macosx/Wish.xcodeproj/project.pbxproj
@@ -2087,10 +2087,13 @@
 		F97AE8330B65C87F00310EA2 /* Wish-Debug.xcconfig */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xcconfig; path = "Wish-Debug.xcconfig"; sourceTree = "<group>"; };
 		F9903CAF094FAADA004613E9 /* tclTomMath.decls */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclTomMath.decls; sourceTree = "<group>"; };
 		F9903CB0094FAADA004613E9 /* tclTomMathDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMathDecls.h; sourceTree = "<group>"; };
+		F99388380EE0114B0065FE6B /* fontchooser.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fontchooser.tcl; sourceTree = "<group>"; };
+		F99388950EE02D980065FE6B /* fontchooser.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fontchooser.test; sourceTree = "<group>"; };
 		F9A3082D08F2D4AB00BAE1AB /* Tk.framework */ = {isa = PBXFileReference; includeInIndex = 0; lastKnownFileType = wrapper.framework; path = Tk.framework; sourceTree = BUILT_PRODUCTS_DIR; };
 		F9A3084B08F2D4CE00BAE1AB /* Wish.app */ = {isa = PBXFileReference; explicitFileType = wrapper.application; includeInIndex = 0; path = Wish.app; sourceTree = BUILT_PRODUCTS_DIR; };
 		F9A3084E08F2D4F400BAE1AB /* Tcl.framework */ = {isa = PBXFileReference; includeInIndex = 0; lastKnownFileType = wrapper.framework; path = Tcl.framework; sourceTree = BUILT_PRODUCTS_DIR; };
 		F9A493240CEBF38300B78AE2 /* chanio.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = chanio.test; sourceTree = "<group>"; };
+		F9C888C20EEF6571003F63AD /* fontchooser.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = fontchooser.n; sourceTree = "<group>"; };
 		F9D1360A0CDC252C00DBE0B5 /* mclist.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = mclist.tcl; sourceTree = "<group>"; };
 		F9ECB1120B26521500A28025 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
 		F9ECB1130B26521500A28025 /* platform.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = platform.tcl; sourceTree = "<group>"; };
@@ -2148,7 +2151,7 @@
 				F966C06F08F281DC005CB29B /* Frameworks */,
 				1AB674ADFE9D54B511CA2CBB /* Products */,
 			);
-			comments = "Copyright (c) 2004-2008 Daniel A. Steffen <das@users.sourceforge.net>\n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.48 2008/12/05 17:10:30 das Exp $\n";
+			comments = "Copyright (c) 2004-2008 Daniel A. Steffen <das@users.sourceforge.net>\n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.49 2008/12/10 05:02:52 das Exp $\n";
 			name = Wish;
 			path = .;
 			sourceTree = SOURCE_ROOT;
@@ -2229,6 +2232,7 @@
 				F966BA3908F27A37005CB29B /* focus.n */,
 				F966BA3A08F27A37005CB29B /* focusNext.n */,
 				F966BA3B08F27A37005CB29B /* font.n */,
+				F9C888C20EEF6571003F63AD /* fontchooser.n */,
 				F966BA3C08F27A37005CB29B /* FontId.3 */,
 				F966BA3D08F27A37005CB29B /* frame.n */,
 				F966BA3E08F27A37005CB29B /* FreeXId.3 */,
@@ -2487,6 +2491,7 @@
 				F966BB6208F27A3A005CB29B /* dialog.tcl */,
 				F966BB6308F27A3A005CB29B /* entry.tcl */,
 				F966BB6408F27A3A005CB29B /* focus.tcl */,
+				F99388380EE0114B0065FE6B /* fontchooser.tcl */,
 				F966BB7308F27A3A005CB29B /* listbox.tcl */,
 				F966BB7408F27A3A005CB29B /* menu.tcl */,
 				F966BB7508F27A3A005CB29B /* mkpsenc.tcl */,
@@ -2691,6 +2696,7 @@
 				F966BC2A08F27A3C005CB29B /* focus.test */,
 				F966BC2B08F27A3C005CB29B /* focusTcl.test */,
 				F966BC2C08F27A3C005CB29B /* font.test */,
+				F99388950EE02D980065FE6B /* fontchooser.test */,
 				F966BC2D08F27A3C005CB29B /* frame.test */,
 				F966BC2E08F27A3C005CB29B /* geometry.test */,
 				F966BC2F08F27A3C005CB29B /* get.test */,
diff --git a/macosx/tkMacOSXCarbonEvents.c b/macosx/tkMacOSXCarbonEvents.c
index f7f04c4..7f99266 100644
--- a/macosx/tkMacOSXCarbonEvents.c
+++ b/macosx/tkMacOSXCarbonEvents.c
@@ -60,7 +60,7 @@
  *	software in accordance with the terms specified in this
  *	license.
  *
- * RCS: @(#) $Id: tkMacOSXCarbonEvents.c,v 1.21 2008/11/08 18:44:40 dkf Exp $
+ * RCS: @(#) $Id: tkMacOSXCarbonEvents.c,v 1.22 2008/12/10 05:02:52 das Exp $
  */
 
 #include "tkMacOSXPrivate.h"
@@ -211,6 +211,8 @@ TkMacOSXInitCarbonEvents(
 	{kEventClassApplication, kEventAppShown},
 	{kEventClassApplication, kEventAppAvailableWindowBoundsChanged},
 	{kEventClassAppearance,	 kEventAppearanceScrollBarVariantChanged},
+	{kEventClassFont,	 kEventFontPanelClosed},
+	{kEventClassFont,	 kEventFontSelection},
     };
 
     carbonEventHandlerUPP = NewEventHandlerUPP(CarbonEventHandlerProc);
diff --git a/macosx/tkMacOSXDialog.c b/macosx/tkMacOSXDialog.c
index 1553592..e283f5c 100644
--- a/macosx/tkMacOSXDialog.c
+++ b/macosx/tkMacOSXDialog.c
@@ -5,12 +5,12 @@
  *
  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
  * Copyright 2001, Apple Computer, Inc.
- * Copyright (c) 2006-2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2006-2008 Daniel A. Steffen <das@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: tkMacOSXDialog.c,v 1.42 2008/12/07 16:36:26 das Exp $
+ * RCS: @(#) $Id: tkMacOSXDialog.c,v 1.43 2008/12/10 05:02:52 das Exp $
  */
 
 #include "tkMacOSXPrivate.h"
@@ -1741,3 +1741,566 @@ AlertHandler(
     }
     return eventNotHandledErr;
 }
+
+/*
+ *----------------------------------------------------------------------
+ */
+#pragma mark [tk fontchooser] implementation (TIP 324)
+/*
+ *----------------------------------------------------------------------
+ */
+
+#include "tkMacOSXEvent.h"
+#include "tkMacOSXFont.h"
+
+typedef struct FontchooserData {
+    Tcl_Obj *titleObj;
+    Tcl_Obj *cmdObj;
+    Tk_Window parent;
+} FontchooserData;
+
+static Tcl_Obj *FontchooserCget(FontchooserData *fcdPtr, int optionIndex);
+static int FontchooserConfigureCmd(ClientData clientData, Tcl_Interp *interp,
+	int objc, Tcl_Obj *const objv[]);
+static int FontchooserShowCmd(ClientData clientData, Tcl_Interp *interp,
+	int objc, Tcl_Obj *const objv[]);
+static int FontchooserHideCmd(ClientData clientData, Tcl_Interp *interp,
+	int objc, Tcl_Obj *const objv[]);
+static void FontchooserParentEventHandler(ClientData clientData,
+	XEvent *eventPtr);
+static void DeleteFontchooserData(ClientData clientData, Tcl_Interp *interp);
+
+MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[];
+const TkEnsemble tkFontchooserEnsemble[] = {
+    { "configure", FontchooserConfigureCmd },
+    { "show", FontchooserShowCmd },
+    { "hide", FontchooserHideCmd },
+};
+
+static Tcl_Interp *fontchooserInterp = NULL;
+static FMFontFamily fontPanelFontFamily = kInvalidFontFamily;
+static FMFontStyle fontPanelFontStyle = -1;
+static FMFontSize fontPanelFontSize = 0;
+static FMFont fontPanelFontID = kInvalidFont;
+
+static const char *fontchooserOptionStrings[] = {
+    "-parent", "-title", "-font", "-command",
+    "-visible", NULL
+};
+enum FontchooserOption {
+    FontchooserParent, FontchooserTitle, FontchooserFont, FontchooserCmd,
+    FontchooserVisible
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkMacOSXProcessFontEvent --
+ *
+ *	This processes events generated by user interaction with the
+ *	font panel.
+ *
+ * Results:
+ *	True if Tk events are generated - false otherwise.
+ *
+ * Side effects:
+ *	Additional events may be place on the Tk event queue.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE int
+TkMacOSXProcessFontEvent(
+    TkMacOSXEvent * eventPtr,
+    MacEventStatus * statusPtr)
+{
+    OSStatus err;
+    int eventGenerated = 0;
+    FontchooserData *fcdPtr;
+
+    switch (eventPtr->eKind) {
+	case kEventFontPanelClosed:
+	case kEventFontSelection:
+	    break;
+	default:
+	    goto done;
+    }
+    if (!fontchooserInterp) {
+	goto done;
+    }
+    fcdPtr = Tcl_GetAssocData(fontchooserInterp, "::tk::fontchooser", NULL);
+    switch (eventPtr->eKind) {
+	case kEventFontPanelClosed:
+	    if (!FPIsFontPanelVisible() && fcdPtr->parent != None) {
+		TkSendVirtualEvent(fcdPtr->parent, "TkFontchooserVisibility");
+		fontchooserInterp = NULL;
+		eventGenerated = 1;
+	    }
+	    break;
+	case kEventFontSelection: {
+	    Tcl_Obj *fontObj = NULL;
+
+	    fontPanelFontFamily = kInvalidFontFamily;
+	    fontPanelFontStyle = -1;
+	    fontPanelFontSize = 0;
+	    fontPanelFontID = kInvalidFont;
+	    err = ChkErr(GetEventParameter, eventPtr->eventRef,
+		    kEventParamFMFontFamily, typeFMFontFamily, NULL,
+		    sizeof(FMFontFamily), NULL, &fontPanelFontFamily);
+	    err |= ChkErr(GetEventParameter, eventPtr->eventRef,
+		    kEventParamFMFontStyle, typeFMFontStyle, NULL,
+		    sizeof(FMFontStyle), NULL, &fontPanelFontStyle);
+	    err |= ChkErr(GetEventParameter, eventPtr->eventRef,
+		    kEventParamFMFontSize, typeFMFontSize, NULL,
+		    sizeof(FMFontSize), NULL, &fontPanelFontSize);
+	    if (err != noErr) {
+		/*
+		 * No/incomplete QD font spec, use ATSUI font ID
+		 */
+		Fixed fontFixedSize;
+
+		err = ChkErr(GetEventParameter, eventPtr->eventRef,
+			kEventParamATSUFontID, typeATSUFontID, NULL,
+			sizeof(ATSUFontID), NULL, &fontPanelFontID);
+		if (err == noErr) {
+		    ChkErr(FMGetFontFamilyInstanceFromFont, fontPanelFontID,
+			    &fontPanelFontFamily, &fontPanelFontStyle);
+		}
+		err = ChkErr(GetEventParameter, eventPtr->eventRef,
+			kEventParamATSUFontSize, typeATSUSize, NULL,
+			sizeof(Fixed), NULL, &fontFixedSize);
+		if (err == noErr) {
+		    fontPanelFontSize = FixedToInt(fontFixedSize);
+		}
+	    }
+	    fontObj = TkMacOSXFontDescriptionForFMFontInfo(
+		fontPanelFontFamily, fontPanelFontStyle,
+		fontPanelFontSize, fontPanelFontID);
+	    if (fontObj) {
+		if (fcdPtr->cmdObj) {
+		    int objc, result;
+		    Tcl_Obj **objv, **tmpv;
+
+		    result = Tcl_ListObjGetElements(fontchooserInterp,
+			    fcdPtr->cmdObj, &objc, &objv);
+		    if (result == TCL_OK) {
+			tmpv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) *
+				(unsigned)(objc + 2));
+			memcpy(tmpv, objv, sizeof(Tcl_Obj *) * objc);
+			tmpv[objc] = fontObj;
+			result = TkBackgroundEvalObjv(fontchooserInterp,
+				objc + 1, tmpv, TCL_EVAL_GLOBAL);
+			ckfree((char *)tmpv);
+		    }
+		}
+		TkSendVirtualEvent(fcdPtr->parent, "TkFontchooserFontChanged");
+	    }
+	    break;
+	}
+    }
+done:
+    return eventGenerated;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FontchooserCget --
+ *
+ *	Helper for the FontchooserConfigure command to return the
+ *	current value of any of the options (which may be NULL in
+ *	the structure)
+ *
+ * Results:
+ *	Tcl object of option value.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+FontchooserCget(
+    FontchooserData *fcdPtr,
+    int optionIndex)
+{
+    Tcl_Obj *resObj = NULL;
+
+    switch(optionIndex) {
+	case FontchooserParent: {
+	    if (fcdPtr->parent != None) {
+		resObj = Tcl_NewStringObj(
+			((TkWindow*)fcdPtr->parent)->pathName, -1);
+	    } else {
+		resObj = Tcl_NewStringObj(".", 1);
+	    }
+	    break;
+	}
+	case FontchooserTitle: {
+	    if (fcdPtr->titleObj) {
+		resObj = fcdPtr->titleObj;
+	    } else {
+		resObj = Tcl_NewObj();
+	    }
+	    break;
+	}
+	case FontchooserFont: {
+	    resObj = TkMacOSXFontDescriptionForFMFontInfo(
+		fontPanelFontFamily, fontPanelFontStyle,
+		fontPanelFontSize, fontPanelFontID);
+	    if (!resObj) {
+		resObj = Tcl_NewObj();
+	    }
+	    break;
+	}
+	case FontchooserCmd: {
+	    if (fcdPtr->cmdObj) {
+		resObj = fcdPtr->cmdObj;
+	    } else {
+		resObj = Tcl_NewObj();
+	    }
+	    break;
+	}
+	case FontchooserVisible: {
+	    resObj = Tcl_NewBooleanObj(FPIsFontPanelVisible());
+	    break;
+	}
+	default: {
+	    resObj = Tcl_NewObj();
+	}
+    }
+    return resObj;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserConfigureCmd --
+ *
+ *	Implementation of the 'tk fontchooser configure' ensemble command.
+ *	See the user documentation for what it does.
+ *
+ * Results:
+ *	See the user documentation.
+ *
+ * Side effects:
+ *	Per-interp data structure may be modified
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserConfigureCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tk_Window tkwin = (Tk_Window)clientData;
+    FontchooserData *fcdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser",
+	    NULL);
+    int i, r = TCL_OK;
+
+    /*
+     * With no arguments we return all the options in a dict
+     */
+
+    if (objc == 1) {
+	Tcl_Obj *keyObj, *valueObj;
+	Tcl_Obj *dictObj = Tcl_NewDictObj();
+	for (i = 0; r == TCL_OK && fontchooserOptionStrings[i] != NULL; ++i) {
+	    keyObj = Tcl_NewStringObj(fontchooserOptionStrings[i], -1);
+	    valueObj = FontchooserCget(fcdPtr, i);
+	    r = Tcl_DictObjPut(interp, dictObj, keyObj, valueObj);
+	}
+	if (r == TCL_OK) {
+	    Tcl_SetObjResult(interp, dictObj);
+	}
+	return r;
+    }
+
+    for (i = 1; i < objc; i += 2) {
+	int optionIndex, len;
+	if (Tcl_GetIndexFromObj(interp, objv[i], fontchooserOptionStrings,
+		"option", 0, &optionIndex) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (objc == 2) {
+	    /* With one option and no arg, return the current value */
+	    Tcl_SetObjResult(interp, FontchooserCget(fcdPtr, optionIndex));
+	    return TCL_OK;
+	}
+	if (i + 1 == objc) {
+	    Tcl_AppendResult(interp, "value for \"",
+		Tcl_GetString(objv[i]), "\" missing", NULL);
+	    return TCL_ERROR;
+	}
+	switch (optionIndex) {
+	    case FontchooserVisible: {
+		const char *msg = "cannot change read-only option "
+		    "\"-visible\": use the show or hide command";
+
+		Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, sizeof(msg)-1));
+		return TCL_ERROR;
+	    }
+	    case FontchooserParent: {
+		Tk_Window parent = Tk_NameToWindow(interp,
+		    Tcl_GetString(objv[i+1]), tkwin);
+		if (parent == None) {
+		    return TCL_ERROR;
+		}
+		if (fcdPtr->parent) {
+		    Tk_DeleteEventHandler(fcdPtr->parent, StructureNotifyMask,
+			    FontchooserParentEventHandler, fcdPtr);
+		}
+		fcdPtr->parent = parent;
+		Tk_CreateEventHandler(fcdPtr->parent, StructureNotifyMask,
+			FontchooserParentEventHandler, fcdPtr);
+		break;
+	    }
+	    case FontchooserTitle:
+		if (fcdPtr->titleObj) {
+		    Tcl_DecrRefCount(fcdPtr->titleObj);
+		}
+		Tcl_GetStringFromObj(objv[i+1], &len);
+		if (len) {
+		    fcdPtr->titleObj = objv[i+1];
+		    if (Tcl_IsShared(fcdPtr->titleObj)) {
+			fcdPtr->titleObj = Tcl_DuplicateObj(fcdPtr->titleObj);
+		    }
+		    Tcl_IncrRefCount(fcdPtr->titleObj);
+		} else {
+		    fcdPtr->titleObj = NULL;
+		}
+		break;
+	    case FontchooserFont: {
+
+		Tcl_GetStringFromObj(objv[i+1], &len);
+		if (len) {
+		    Tk_Font f = Tk_AllocFontFromObj(interp, tkwin, objv[i+1]);
+		    if (f) {
+			ATSUStyle atsuStyle;
+
+			TkMacOSXFMFontInfoForFont(f, &fontPanelFontFamily,
+				 &fontPanelFontStyle, &fontPanelFontSize,
+				 &atsuStyle);
+			ChkErr(SetFontInfoForSelection,
+				kFontSelectionATSUIType, 1, &atsuStyle, NULL);
+			Tk_FreeFont(f);
+		    } else {
+			return TCL_ERROR;
+		    }
+		} else {
+		    fontPanelFontFamily = kInvalidFontFamily;
+		    ChkErr(SetFontInfoForSelection,
+			    kFontSelectionATSUIType, 0, NULL, NULL);
+		}
+		if (FPIsFontPanelVisible()) {
+		    TkSendVirtualEvent(fcdPtr->parent,
+			    "TkFontchooserFontChanged");
+		}
+		break;
+	    }
+	    case FontchooserCmd:
+		if (fcdPtr->cmdObj) {
+		    Tcl_DecrRefCount(fcdPtr->cmdObj);
+		}
+		Tcl_GetStringFromObj(objv[i+1], &len);
+		if (len) {
+		    fcdPtr->cmdObj = objv[i+1];
+		    if (Tcl_IsShared(fcdPtr->cmdObj)) {
+			fcdPtr->cmdObj = Tcl_DuplicateObj(fcdPtr->cmdObj);
+		    }
+		    Tcl_IncrRefCount(fcdPtr->cmdObj);
+		} else {
+		    fcdPtr->cmdObj = NULL;
+		}
+		break;
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserShowCmd --
+ *
+ *	Implements the 'tk fontchooser show' ensemble command. The
+ *	per-interp configuration data for the dialog is held in an interp
+ *	associated structure.
+ *
+ * Results:
+ *	See the user documentation.
+ *
+ * Side effects:
+ *	Font Panel may be shown.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserShowCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    FontchooserData *fcdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser",
+	    NULL);
+
+    if (fcdPtr->parent == None) {
+	fcdPtr->parent = (Tk_Window) clientData;
+	Tk_CreateEventHandler(fcdPtr->parent, StructureNotifyMask,
+		FontchooserParentEventHandler, fcdPtr);
+    }
+    if (!FPIsFontPanelVisible()) {
+	ChkErr(FPShowHideFontPanel);
+	TkSendVirtualEvent(fcdPtr->parent, "TkFontchooserVisibility");
+    }
+    fontchooserInterp = interp;
+
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserHideCmd --
+ *
+ *	Implementation of the 'tk fontchooser hide' ensemble. See the
+ *	user documentation for details.
+ *
+ * Results:
+ *	See the user documentation.
+ *
+ * Side effects:
+ *	Font Panel may be hidden.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserHideCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    if (FPIsFontPanelVisible()) {
+	ChkErr(FPShowHideFontPanel);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserParentEventHandler --
+ *
+ *	Event handler for StructureNotify events on the font chooser's
+ *	parent window.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Font chooser parent info is cleared and font panel is hidden.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+FontchooserParentEventHandler(
+    ClientData clientData,
+    XEvent *eventPtr)
+{
+    FontchooserData *fcdPtr = clientData;
+
+    if (eventPtr->type == DestroyNotify) {
+	Tk_DeleteEventHandler(fcdPtr->parent, StructureNotifyMask,
+		FontchooserParentEventHandler, fcdPtr);
+	fcdPtr->parent = None;
+	if (FPIsFontPanelVisible()) {
+	    ChkErr(FPShowHideFontPanel);
+	}
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteFontchooserData --
+ *
+ *	Clean up the font chooser configuration data when the interp
+ *	is destroyed.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	per-interp configuration data is destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteFontchooserData(
+    ClientData clientData,
+    Tcl_Interp *interp)
+{
+    FontchooserData *fcdPtr = clientData;
+
+    if (fcdPtr->titleObj) {
+	Tcl_DecrRefCount(fcdPtr->titleObj);
+    }
+    if (fcdPtr->cmdObj) {
+	Tcl_DecrRefCount(fcdPtr->cmdObj);
+    }
+    ckfree((char *)fcdPtr);
+
+    if (fontchooserInterp == interp) {
+	fontchooserInterp = NULL;
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TkInitFontchooser --
+ *
+ *	Associate the font chooser configuration data with the Tcl
+ *	interpreter. There is one font chooser per interp.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	per-interp configuration data is destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE int
+TkInitFontchooser(
+    Tcl_Interp *interp,
+    ClientData clientData)
+{
+    FontchooserData *fcdPtr = (FontchooserData*)
+	    ckalloc(sizeof(FontchooserData));
+
+    bzero(fcdPtr, sizeof(FontchooserData));
+    Tcl_SetAssocData(interp, "::tk::fontchooser", DeleteFontchooserData,
+	    fcdPtr);
+    return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 79
+ * coding: utf-8
+ * End:
+ */
diff --git a/macosx/tkMacOSXEvent.c b/macosx/tkMacOSXEvent.c
index 11114c2..9ca301d 100644
--- a/macosx/tkMacOSXEvent.c
+++ b/macosx/tkMacOSXEvent.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkMacOSXEvent.c,v 1.24 2008/10/27 11:55:44 dkf Exp $
+ * RCS: @(#) $Id: tkMacOSXEvent.c,v 1.25 2008/12/10 05:02:52 das Exp $
  */
 
 #include "tkMacOSXPrivate.h"
@@ -103,6 +103,9 @@ TkMacOSXProcessEvent(
     case kEventClassCommand:
 	TkMacOSXProcessCommandEvent(eventPtr, statusPtr);
 	break;
+    case kEventClassFont:
+	TkMacOSXProcessFontEvent(eventPtr, statusPtr);
+	break;
     default: {
 	TkMacOSXDbgMsg("Unrecognised event: %s",
 		TkMacOSXCarbonEventToAscii(eventPtr->eventRef));
diff --git a/macosx/tkMacOSXEvent.h b/macosx/tkMacOSXEvent.h
index 7fcb503..921e408 100644
--- a/macosx/tkMacOSXEvent.h
+++ b/macosx/tkMacOSXEvent.h
@@ -54,7 +54,7 @@
  *	software in accordance with the terms specified in this
  *	license.
  *
- * RCS: @(#) $Id: tkMacOSXEvent.h,v 1.12 2007/04/23 21:24:33 das Exp $
+ * RCS: @(#) $Id: tkMacOSXEvent.h,v 1.13 2008/12/10 05:02:52 das Exp $
  */
 
 #ifndef _TKMACEVENT
@@ -98,6 +98,8 @@ MODULE_SCOPE int TkMacOSXProcessMenuEvent(TkMacOSXEvent *e,
 	MacEventStatus *statusPtr);
 MODULE_SCOPE int TkMacOSXProcessCommandEvent(TkMacOSXEvent *e,
 	MacEventStatus *statusPtr);
+MODULE_SCOPE int TkMacOSXProcessFontEvent(TkMacOSXEvent *e,
+	MacEventStatus *statusPtr);
 MODULE_SCOPE int TkMacOSXKeycodeToUnicode(
 	UniChar * uniChars, int maxChars,
 	EventKind eKind,
diff --git a/macosx/tkMacOSXFont.c b/macosx/tkMacOSXFont.c
index aa4ea0c..51d0c4d 100644
--- a/macosx/tkMacOSXFont.c
+++ b/macosx/tkMacOSXFont.c
@@ -35,7 +35,7 @@
  *   that such fonts can not be used for controls, because controls
  *   definitely require a family id (this assertion needs testing).
  *
- * RCS: @(#) $Id: tkMacOSXFont.c,v 1.42 2008/11/22 22:29:14 das Exp $
+ * RCS: @(#) $Id: tkMacOSXFont.c,v 1.43 2008/12/10 05:02:52 das Exp $
  */
 
 #include "tkMacOSXPrivate.h"
@@ -2517,6 +2517,103 @@ TkMacOSXInitControlFontStyle(
 /*
  *----------------------------------------------------------------------
  *
+ * TkMacOSXFMFontInfoForFont --
+ *
+ *	Retrieve FontManager/ATSUI font information for a Tk font.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE void
+TkMacOSXFMFontInfoForFont(
+    Tk_Font tkfont,
+    FMFontFamily *fontFamilyPtr,
+    FMFontStyle *fontStylePtr,
+    FMFontSize *fontSizePtr,
+    ATSUStyle *fontATSUStylePtr)
+{
+    const MacFont * fontPtr = (MacFont *) tkfont;
+
+    if (fontFamilyPtr) {
+	*fontFamilyPtr = fontPtr->qdFont;
+    }
+    if (fontStylePtr) {
+	*fontStylePtr = fontPtr->qdStyle;
+    }
+    if (fontSizePtr) {
+	*fontSizePtr = fontPtr->qdSize;
+    }
+    if (fontATSUStylePtr) {
+	*fontATSUStylePtr = fontPtr->atsuStyle;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkMacOSXFontDescriptionForFMFontInfo --
+ *
+ *	Get text description of a font specified by FontManager info.
+ *
+ * Results:
+ *	List object or NULL.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE Tcl_Obj *
+TkMacOSXFontDescriptionForFMFontInfo(
+    FMFontFamily fontFamily,
+    FMFontStyle fontStyle,
+    FMFontSize fontSize,
+    FMFont fontID)
+{
+    Tcl_Obj *objv[6];
+    int i = 0;
+
+    if (fontFamily != kInvalidFontFamily && fontStyle != -1) {
+	const char *familyName = FamilyNameForFamilyID(fontFamily);
+
+	if (familyName) {
+	    objv[i++] = Tcl_NewStringObj(familyName, -1);
+	    objv[i++] = Tcl_NewIntObj(fontSize);
+#define S(s) Tcl_NewStringObj(STRINGIFY(s),(int)(sizeof(STRINGIFY(s))-1))
+	    objv[i++] = (fontStyle & bold)	? S(bold)   : S(normal);
+	    objv[i++] = (fontStyle & italic)	? S(italic) : S(roman);
+	    if (fontStyle & underline) objv[i++] = S(underline);
+	    /*if (fontStyle & overstrike) objv[i++] = S(overstrike);*/
+#undef S
+	}
+    } else if (fontID != kInvalidFont) {
+	CFStringRef fontName = NULL;
+	Tcl_Obj *fontNameObj = NULL;
+
+	ChkErr(ATSFontGetName, FMGetATSFontRefFromFont(fontID),
+		kATSOptionFlagsDefault, &fontName);
+	if (fontName) {
+	    fontNameObj = TkMacOSXGetStringObjFromCFString(fontName);
+	    CFRelease(fontName);
+	}
+	if (fontNameObj) {
+	    objv[i++] = fontNameObj;
+	    objv[i++] = Tcl_NewIntObj(fontSize);
+	}
+    }
+    return i ? Tcl_NewListObj(i, objv) : NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TkMacOSXUseAntialiasedText --
  *
  *	Enables or disables application-wide use of antialiased text (where
diff --git a/macosx/tkMacOSXFont.h b/macosx/tkMacOSXFont.h
index 56c0bbc..9c88409 100644
--- a/macosx/tkMacOSXFont.h
+++ b/macosx/tkMacOSXFont.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkMacOSXFont.h,v 1.5 2007/04/23 21:24:33 das Exp $
+ * RCS: @(#) $Id: tkMacOSXFont.h,v 1.6 2008/12/10 05:02:52 das Exp $
  */
 
 #ifndef TKMACOSXFONT_H
@@ -30,5 +30,11 @@
 
 MODULE_SCOPE void TkMacOSXInitControlFontStyle(Tk_Font tkfont,
 	ControlFontStylePtr fsPtr);
+MODULE_SCOPE void TkMacOSXFMFontInfoForFont(Tk_Font tkfont,
+	FMFontFamily *fontFamilyPtr, FMFontStyle *fontStylePtr,
+	FMFontSize *fontSizePtr, ATSUStyle *fontATSUStylePtr);
+MODULE_SCOPE Tcl_Obj * TkMacOSXFontDescriptionForFMFontInfo(
+	FMFontFamily fontFamily, FMFontStyle fontStyle, FMFontSize fontSize,
+	FMFont fontID);
 
 #endif /*TKMACOSXFONT_H*/
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}
 }
diff --git a/win/tkWinDialog.c b/win/tkWinDialog.c
index 8f41788..0f03f1d 100644
--- a/win/tkWinDialog.c
+++ b/win/tkWinDialog.c
@@ -8,12 +8,13 @@
  * 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.55 2008/11/08 18:44:40 dkf Exp $
+ * RCS: @(#) $Id: tkWinDialog.c,v 1.56 2008/12/10 05:02:52 das Exp $
  *
  */
 
 #include "tkWinInt.h"
 #include "tkFileFilter.h"
+#include "tkFont.h"
 
 #include <commdlg.h>		/* includes common dialog functionality */
 #ifdef _MSC_VER
@@ -2258,6 +2259,19 @@ MsgBoxCBTProc(
     return CallNextHookEx(tsdPtr->hMsgBoxHook, nCode, wParam, lParam);
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SetTkDialog --
+ *
+ *	Records the HWND for a native dialog in the 'tk_dialog' variable
+ *	so that the test-suite can operate on the correct dialog window.
+ *	Use of this is enabled when a test program calls TkWinDialogDebug
+ *	by calling the test command 'tkwinevent debug 1'
+ *
+ * ----------------------------------------------------------------------
+ */
+
 static void
 SetTkDialog(
     ClientData clientData)
@@ -2296,6 +2310,531 @@ ConvertExternalFilename(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+    TkBackgroundEvalObjv(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;
+    Tk_Window parent;
+} HookData;
+
+static UINT_PTR CALLBACK
+HookProc(HWND hwndDlg, UINT msg, WPARAM wParam, LPARAM lParam)
+{
+    CHOOSEFONT *pcf = (CHOOSEFONT *)lParam;
+    HWND hwndCtrl;
+    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) {
+	    Tcl_DString title;
+	    Tcl_WinUtfToTChar(Tcl_GetString(phd->titleObj), -1, &title);
+	    if (Tcl_DStringLength(&title) > 0) {
+		tkWinProcs->setWindowText(hwndDlg,
+		    (LPCTSTR)Tcl_DStringValue(&title));
+	    }
+	    Tcl_DStringFree(&title);
+	}
+
+	/*
+	 * Disable the colour combobox (0x473) and its label (0x443).
+	 */
+
+	hwndCtrl = GetDlgItem(hwndDlg, 0x443);
+	if (IsWindow(hwndCtrl)) {
+	    EnableWindow(hwndCtrl, FALSE);
+	}
+	hwndCtrl = GetDlgItem(hwndDlg, 0x473);
+	if (IsWindow(hwndCtrl)) {
+	    EnableWindow(hwndCtrl, FALSE);
+	}
+	TkSendVirtualEvent(phd->parent, "TkFontchooserVisibility");
+	return 1; /* we handled the message */
+    }
+
+    if (WM_DESTROY == msg) {
+	phd->hwnd = NULL;
+	TkSendVirtualEvent(phd->parent, "TkFontchooserVisibility");
+	return 0;
+    }
+
+    /*
+     * 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);
+	}
+	if (phd && phd->parent) {
+	    TkSendVirtualEvent(phd->parent, "TkFontchooserFontChanged");
+	}
+	return 1;
+    }
+    return 0; /* pass on for default processing */
+}
+
+/*
+ * Helper for the FontchooserConfigure command to return the
+ * current value of any of the options (which may be NULL in
+ * the structure)
+ */
+
+enum FontchooserOption {
+    FontchooserParent, FontchooserTitle, FontchooserFont, FontchooserCmd,
+    FontchooserVisible
+};
+
+static Tcl_Obj *
+FontchooserCget(HookData *hdPtr, int optionIndex)
+{
+    Tcl_Obj *resObj = NULL;
+    switch(optionIndex) {
+	case FontchooserParent: {
+	    if (hdPtr->parentObj) {
+		resObj = hdPtr->parentObj;
+	    } else {
+		resObj = Tcl_NewStringObj(".", 1);
+	    }
+	    break;
+	}
+	case FontchooserTitle: {
+	    if (hdPtr->titleObj) {
+		resObj = hdPtr->titleObj;
+	    } else {
+		resObj =  Tcl_NewStringObj("", 0);
+	    }
+	    break;
+	}
+	case FontchooserFont: {
+	    if (hdPtr->fontObj) {
+		resObj = hdPtr->fontObj;
+	    } else {
+		resObj = Tcl_NewStringObj("", 0);
+	    }
+	    break;
+	}
+	case FontchooserCmd: {
+	    if (hdPtr->cmdObj) {
+		resObj = hdPtr->cmdObj;
+	    } else {
+		resObj = Tcl_NewStringObj("", 0);
+	    }
+	    break;
+	}
+	case FontchooserVisible: {
+	    resObj = Tcl_NewBooleanObj(hdPtr->hwnd && IsWindow(hdPtr->hwnd));
+	    break;
+	}
+	default: {
+	    resObj = Tcl_NewStringObj("", 0);
+	}
+    }
+    return resObj;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserConfigureCmd --
+ *
+ *	Implementation of the 'tk fontchooser configure' ensemble command.
+ *	See the user documentation for what it does.
+ *
+ * Results:
+ *	See the user documentation.
+ *
+ * Side effects:
+ *	Per-interp data structure may be modified
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserConfigureCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tk_Window tkwin = (Tk_Window)clientData;
+    HookData *hdPtr = NULL;
+    int i, r = TCL_OK;
+    static const char *optionStrings[] = {
+	"-parent", "-title", "-font", "-command", "-visible", NULL
+    };
+
+    hdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser", NULL);
+
+    /*
+     * with no arguments we return all the options in a dict
+     */
+
+    if (objc == 1) {
+	Tcl_Obj *keyObj, *valueObj;
+	Tcl_Obj *dictObj = Tcl_NewDictObj();
+	for (i = 0; r == TCL_OK && optionStrings[i] != NULL; ++i) {
+	    keyObj = Tcl_NewStringObj(optionStrings[i], -1);
+	    valueObj = FontchooserCget(hdPtr, i);
+	    r = Tcl_DictObjPut(interp, dictObj, keyObj, valueObj);
+	}
+	if (r == TCL_OK) {
+	    Tcl_SetObjResult(interp, dictObj);
+	}
+	return r;
+    }
+
+    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 (objc == 2) {
+	    /* if one option and no arg - return the current value */
+	    Tcl_SetObjResult(interp, FontchooserCget(hdPtr, optionIndex));
+	    return TCL_OK;
+	}
+	if (i + 1 == objc) {
+	    Tcl_AppendResult(interp, "value for \"",
+		Tcl_GetString(objv[i]), "\" missing", NULL);
+	    return TCL_ERROR;
+	}
+	switch (optionIndex) {
+	    case FontchooserVisible: {
+		const char *msg = "cannot change read-only option "
+		    "\"-visible\": use the show or hide command";
+		Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+		return TCL_ERROR;
+	    }
+	    case FontchooserParent: {
+		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 FontchooserTitle: {
+		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 FontchooserFont: {
+		if (hdPtr->fontObj) {
+		    Tcl_DecrRefCount(hdPtr->fontObj);
+		}
+		Tcl_GetStringFromObj(objv[i+1], &len);
+		if (len) {
+		    hdPtr->fontObj = objv[i+1];
+		    if (Tcl_IsShared(hdPtr->fontObj)) {
+			hdPtr->fontObj = Tcl_DuplicateObj(hdPtr->fontObj);
+		    }
+		    Tcl_IncrRefCount(hdPtr->fontObj);
+		} else {
+		    hdPtr->fontObj = NULL;
+		}
+		break;
+	    }
+	    case FontchooserCmd: {
+		if (hdPtr->cmdObj) {
+		    Tcl_DecrRefCount(hdPtr->cmdObj);
+		}
+		Tcl_GetStringFromObj(objv[i+1], &len);
+		if (len) {
+		    hdPtr->cmdObj = objv[i+1];
+		    if (Tcl_IsShared(hdPtr->cmdObj)) {
+			hdPtr->cmdObj = Tcl_DuplicateObj(hdPtr->cmdObj);
+		    }
+		    Tcl_IncrRefCount(hdPtr->cmdObj);
+		} else {
+		    hdPtr->cmdObj = NULL;
+		}
+		break;
+	    }
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserShowCmd --
+ *
+ *	Implements the 'tk fontchooser show' ensemble command. The
+ *	per-interp configuration data for the dialog is held in an interp
+ *	associated structure.
+ *	Calls the Win32 FontChooser API which provides a modal dialog.
+ *	See HookProc where we make a few changes to the dialog and set
+ *	some additional state.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserShowCmd(
+    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::fontchooser", 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;
+    hdPtr->parent = parent;
+    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 (FontChooser(&cf)) {
+	    if (hdPtr->cmdObj) {
+		ApplyLogfont(hdPtr->interp, hdPtr->cmdObj, hdc, &lf);
+	    }
+	    if (hdPtr->parent) {
+		TkSendVirtualEvent(hdPtr->parent, "TkFontchooserFontChanged");
+	    }
+	}
+	Tcl_SetServiceMode(oldMode);
+	EnableWindow(cf.hwndOwner, 1);
+    }
+
+    ReleaseDC(cf.hwndOwner, hdc);
+
+    return r;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserHideCmd --
+ *
+ *	Implementation of the 'tk fontchooser hide' ensemble. See the
+ *	user documentation for details.
+ *	As the Win32 FontChooser function is always modal all we do here
+ *	is destroy the dialog
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserHideCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    HookData *hdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser", NULL);
+    if (hdPtr->hwnd && IsWindow(hdPtr->hwnd)) {
+	EndDialog(hdPtr->hwnd, 0);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteHookData --
+ *
+ *	Clean up the font chooser configuration data when the interp
+ *	is destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TkInitFontchooser --
+ *
+ *	Associate the font chooser configuration data with the Tcl
+ *	interpreter. There is one font chooser per interp.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[];
+const TkEnsemble tkFontchooserEnsemble[] = {
+    { "configure", FontchooserConfigureCmd, NULL },
+    { "show", FontchooserShowCmd, NULL },
+    { "hide", FontchooserHideCmd, NULL },
+};
+
+int
+TkInitFontchooser(Tcl_Interp *interp, ClientData clientData)
+{
+    HookData *hdPtr = NULL;
+    hdPtr = (HookData *)ckalloc(sizeof(HookData));
+    memset(hdPtr, 0, sizeof(HookData));
+    Tcl_SetAssocData(interp, "::tk::fontchooser", DeleteHookData, hdPtr);
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/win/tkWinInt.h b/win/tkWinInt.h
index aa35ed0..469d6e9 100644
--- a/win/tkWinInt.h
+++ b/win/tkWinInt.h
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkWinInt.h,v 1.31 2007/12/14 15:56:09 patthoyts Exp $
+ * RCS: @(#) $Id: tkWinInt.h,v 1.32 2008/12/10 05:02:52 das Exp $
  */
 
 #ifndef _TKWININT
@@ -211,6 +211,8 @@ typedef struct TkWinProcs {
     BOOL (WINAPI *insertMenu)(HMENU hMenu, UINT uPosition, UINT uFlags,
 	    UINT uIDNewItem, LPCTSTR lpNewItem);
     int (WINAPI *getWindowText)(HWND hWnd, LPCTSTR lpString, int nMaxCount);
+    HWND (WINAPI *findWindow)(LPCTSTR lpClassName, LPCTSTR lpWindowName);
+    int (WINAPI *getClassName)(HWND hwnd, LPTSTR lpClassName, int nMaxCount);
 } TkWinProcs;
 
 EXTERN TkWinProcs *tkWinProcs;
diff --git a/win/tkWinTest.c b/win/tkWinTest.c
index c48dba5..3060dda 100644
--- a/win/tkWinTest.c
+++ b/win/tkWinTest.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkWinTest.c,v 1.23 2008/11/27 23:26:05 nijtmans Exp $
+ * RCS: @(#) $Id: tkWinTest.c,v 1.24 2008/12/10 05:02:52 das Exp $
  */
 
 #include "tkWinInt.h"
@@ -373,18 +373,25 @@ TestfindwindowObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument values. */
 {
-    const char *title = NULL, *class = NULL;
+    const TCHAR  *title = NULL, *class = NULL;
+    Tcl_DString titleString, classString;
     HWND hwnd = NULL;
     int r = TCL_OK;
 
+    Tcl_DStringInit(&classString);
+    Tcl_DStringInit(&titleString);
+
     if (objc < 2 || objc > 3) {
         Tcl_WrongNumArgs(interp, 1, objv, "title ?class?");
         return TCL_ERROR;
     }
-    title = Tcl_GetString(objv[1]);
-    if (objc == 3)
-        class = Tcl_GetString(objv[2]);
-    hwnd = FindWindowA(class, title);
+
+    title = Tcl_WinUtfToTChar(Tcl_GetString(objv[1]), -1, &titleString);
+    if (objc == 3) {
+        class = Tcl_WinUtfToTChar(Tcl_GetString(objv[2]), -1, &classString);
+    }
+
+    hwnd  = tkWinProcs->findWindow(class, title);
 
     if (hwnd == NULL) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to find window: ", -1));
@@ -393,6 +400,9 @@ TestfindwindowObjCmd(
     } else {
         Tcl_SetObjResult(interp, Tcl_NewLongObj((long)hwnd));
     }
+
+    Tcl_DStringFree(&titleString);
+    Tcl_DStringFree(&classString);
     return r;
 
 }
@@ -416,7 +426,7 @@ TestgetwindowinfoObjCmd(
     Tcl_Obj *const objv[])
 {
     HWND hwnd = NULL;
-    Tcl_Obj *resObj = NULL, *classObj = NULL, *textObj = NULL;
+    Tcl_Obj *dictObj = NULL, *classObj = NULL, *textObj = NULL;
     Tcl_Obj *childrenObj = NULL;
     char buf[512];
     int cch, cchBuf = tkWinProcs->useWide ? 256 : 512;
@@ -429,25 +439,21 @@ TestgetwindowinfoObjCmd(
     if (Tcl_GetLongFromObj(interp, objv[1], (long *)&hwnd) != TCL_OK)
 	return TCL_ERROR;
 
-    if (tkWinProcs->useWide) {
-	cch = GetClassNameW(hwnd, (LPWSTR)buf, sizeof(buf)/sizeof(WCHAR));
-	classObj = Tcl_NewUnicodeObj((LPWSTR)buf, cch);
-    } else {
-	cch = GetClassNameA(hwnd, (LPSTR)buf, sizeof(buf));
-	classObj = Tcl_NewStringObj((LPSTR)buf, cch);
-    }
+    cch = tkWinProcs->getClassName(hwnd, buf, cchBuf);
     if (cch == 0) {
     	Tcl_SetResult(interp, "failed to get class name: ", TCL_STATIC);
     	AppendSystemError(interp, GetLastError());
     	return TCL_ERROR;
+    } else {
+	Tcl_DString ds;
+	Tcl_WinTCharToUtf(buf, -1, &ds);
+	classObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+	Tcl_DStringFree(&ds);
     }
 
-    resObj = Tcl_NewListObj(0, NULL);
-    Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("class", -1));
-    Tcl_ListObjAppendElement(interp, resObj, classObj);
-
-    Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("id", -1));
-    Tcl_ListObjAppendElement(interp, resObj,
+    dictObj = Tcl_NewDictObj();
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("class", 5), classObj);
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("id", 2),
 	Tcl_NewLongObj(GetWindowLong(hwnd, GWL_ID)));
 
     cch = tkWinProcs->getWindowText(hwnd, (LPTSTR)buf, cchBuf);
@@ -457,18 +463,15 @@ TestgetwindowinfoObjCmd(
 	textObj = Tcl_NewStringObj((LPCSTR)buf, cch);
     }
 
-    Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("text", -1));
-    Tcl_ListObjAppendElement(interp, resObj, textObj);
-    Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("parent", -1));
-    Tcl_ListObjAppendElement(interp, resObj,
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("text", 4), textObj);
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("parent", 6),
 	Tcl_NewLongObj((long)GetParent(hwnd)));
 
     childrenObj = Tcl_NewListObj(0, NULL);
     EnumChildWindows(hwnd, EnumChildrenProc, (LPARAM)childrenObj);
-    Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("children", -1));
-    Tcl_ListObjAppendElement(interp, resObj, childrenObj);
+    Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("children", -1), childrenObj);
 
-    Tcl_SetObjResult(interp, resObj);
+    Tcl_SetObjResult(interp, dictObj);
     return TCL_OK;
 }
 
diff --git a/win/tkWinX.c b/win/tkWinX.c
index 9632bd2..160e141 100644
--- a/win/tkWinX.c
+++ b/win/tkWinX.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkWinX.c,v 1.58 2008/04/27 22:39:17 dkf Exp $
+ * RCS: @(#) $Id: tkWinX.c,v 1.59 2008/12/10 05:02:52 das Exp $
  */
 
 /*
@@ -79,6 +79,8 @@ static TkWinProcs asciiProcs = {
     (BOOL (WINAPI *)(HMENU hMenu, UINT uPosition, UINT uFlags,
 	    UINT uIDNewItem, LPCTSTR lpNewItem)) InsertMenuA,
     (int (WINAPI *)(HWND hWnd, LPCTSTR lpString, int nMaxCount)) GetWindowTextA,
+    (HWND (WINAPI *)(LPCTSTR lpClassName, LPCTSTR lpWindowName)) FindWindowA,
+    (int (WINAPI *)(HWND hwnd, LPTSTR lpClassName, int nMaxCount)) GetClassNameA,
 };
 
 static TkWinProcs unicodeProcs = {
@@ -97,6 +99,8 @@ static TkWinProcs unicodeProcs = {
     (BOOL (WINAPI *)(HMENU hMenu, UINT uPosition, UINT uFlags,
 	    UINT uIDNewItem, LPCTSTR lpNewItem)) InsertMenuW,
     (int (WINAPI *)(HWND hWnd, LPCTSTR lpString, int nMaxCount)) GetWindowTextW,
+    (HWND (WINAPI *)(LPCTSTR lpClassName, LPCTSTR lpWindowName)) FindWindowW,
+    (int (WINAPI *)(HWND hwnd, LPTSTR lpClassName, int nMaxCount)) GetClassNameW,
 };
 
 TkWinProcs *tkWinProcs;
author	das <das@noemail.net>	2008-12-10 05:02:38 (GMT)
committer	das <das@noemail.net>	2008-12-10 05:02:38 (GMT)
commit	0be6d3101da9d47238f246b7d4f522705a04779b (patch)
tree	2f061501366a0706fb1db4d2cd36d5c490ace9f6
parent	4c95ed16d07fab4fa052d2120afcae6c21f1a899 (diff)
download	tk-0be6d3101da9d47238f246b7d4f522705a04779b.zip tk-0be6d3101da9d47238f246b7d4f522705a04779b.tar.gz tk-0be6d3101da9d47238f246b7d4f522705a04779b.tar.bz2