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