Attachment "tk_tip213-080619.diff" to
ticket [1477426f]
added by
das
2008-06-19 07:26:41.
Index: generic/tkInt.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkInt.h,v
retrieving revision 1.83
diff -u -p -r1.83 tkInt.h
--- generic/tkInt.h 2 Apr 2008 21:32:32 -0000 1.83
+++ generic/tkInt.h 19 Jun 2008 00:17:39 -0000
@@ -852,6 +852,17 @@ typedef struct TkWindow {
} 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_CanvasObjCmd(ClientD
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[]);
@@ -1200,6 +1213,12 @@ MODULE_SCOPE void TkUnderlineCharsInCont
int firstByte, int lastByte);
MODULE_SCOPE void TkpGetFontAttrsForChar(Tk_Window tkwin, Tk_Font tkfont,
Tcl_UniChar c, struct TkFontAttributes *faPtr);
+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);
/*
* Unsupported commands.
Index: generic/tkUtil.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkUtil.c,v
retrieving revision 1.21
diff -u -p -r1.21 tkUtil.c
--- generic/tkUtil.c 13 Dec 2007 15:24:21 -0000 1.21
+++ generic/tkUtil.c 19 Jun 2008 00:17:39 -0000
@@ -978,6 +978,202 @@ 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 --
+ *
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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
* c-basic-offset: 4
Index: generic/tkWindow.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkWindow.c,v
retrieving revision 1.95
diff -u -p -r1.95 tkWindow.c
--- generic/tkWindow.c 27 Apr 2008 22:38:58 -0000 1.95
+++ generic/tkWindow.c 19 Jun 2008 00:17:39 -0000
@@ -94,11 +94,12 @@ static XSetWindowAttributes defAtts= {
* 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 @@ static TkCmd commands[] = {
* 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,12 @@ static TkCmd commands[] = {
*/
#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},
+ {"::tk::choosefont",NULL, NULL, TkChoosefontInit, 0, 1},
#endif
/*
@@ -198,9 +200,9 @@ static TkCmd commands[] = {
#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 +950,8 @@ TkCreateMainWindow(
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 +959,9 @@ TkCreateMainWindow(
} 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 -p -r1.38 console.tcl
--- library/console.tcl 13 May 2008 13:25:18 -0000 1.38
+++ library/console.tcl 19 Jun 2008 00:17:39 -0000
@@ -26,7 +26,6 @@ namespace eval ::tk::console {
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 {[llength [info command ::tk::choosefont]]} {
+ 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::ChooseFont]
+ bind Console <<TkChoosefontVisibility>> \
+ [list ::tk::console::ChooseFontVisibility $index]
+ ::tk::console::ChooseFontVisibility $index
+ } else {
+ AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
+ -command [list ::tk::console::ChooseFont]
+ }
+ bind Console <FocusIn> [list ::tk::console::ChooseFontFocus %W 1]
+ bind Console <FocusOut> [list ::tk::console::ChooseFontFocus %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 {[llength [info command ::tk::choosefont]]} {
+ bind Console <Command-Key-t> [list ::tk::console::ChooseFont]
+ }
}
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 {[llength [info command ::tk::choosefont]]} {
+ ::tk::choosefont 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 {[llength [info command ::tk::choosefont]]} {
+ ::tk::choosefont configure -font TkConsoleFont
+ }
}
##
@@ -669,6 +695,35 @@ Tcl $::tcl_patchLevel
Tk $::tk_patchLevel"
}
+# ::tk::console::ChooseFont --
+# Let the user select the console font (TIP 213).
+
+proc ::tk::console::ChooseFont {} {
+ if {[tk::choosefont configure -visible]} {
+ ::tk::choosefont hide
+ } else {
+ ::tk::choosefont show
+ }
+}
+proc ::tk::console::ChooseFontVisibility {index} {
+ if {[::tk::choosefont configure -visible]} {
+ .menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"]
+ } else {
+ .menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"]
+ }
+}
+proc ::tk::console::ChooseFontFocus {w isFocusIn} {
+ if {$isFocusIn} {
+ ::tk::choosefont configure -parent $w -font TkConsoleFont \
+ -command [namespace code [list ApplyFont]]
+ } else {
+ ::tk::choosefont configure -parent $w -font {} -command {}
+ }
+}
+proc ::tk::console::ApplyFont {font args} {
+ catch {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 19 Jun 2008 00:17:39 -0000
@@ -0,0 +1,390 @@
+# 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)]} {
+ Create
+ 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 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 {[string trim $S(-title)] eq ""} {
+ set S(-title) [::msgcat::mc "Font"]
+ }
+}
+
+proc ::tk::choosefont::Create {} {
+ variable S
+ set windowName __tk__choosefont
+ 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
+ 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::Visibility --
+#
+# Notify the parent when the dialog visibility changes
+#
+proc ::tk::choosefont::Visibility {w visible} {
+ variable S
+ if {$w eq $S(W)} {
+ event generate $S(-parent) <<TkChoosefontVisibility>>
+ }
+}
+
+# ::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 -p -r1.10 tclIndex
--- library/tclIndex 30 Oct 2007 01:57:54 -0000 1.10
+++ library/tclIndex 19 Jun 2008 00:17:39 -0000
@@ -276,3 +276,4 @@ set auto_index(::tk::ListBoxKeyAccel_Res
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/msgs/de.msg
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/msgs/de.msg,v
retrieving revision 1.7
diff -u -p -r1.7 de.msg
--- library/msgs/de.msg 14 Nov 2007 14:07:04 -0000 1.7
+++ library/msgs/de.msg 19 Jun 2008 00:17:40 -0000
@@ -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"
Index: library/msgs/en.msg
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/msgs/en.msg,v
retrieving revision 1.6
diff -u -p -r1.6 en.msg
--- library/msgs/en.msg 6 Dec 2007 16:05:47 -0000 1.6
+++ library/msgs/en.msg 19 Jun 2008 00:17:40 -0000
@@ -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"
Index: macosx/tkMacOSXCarbonEvents.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXCarbonEvents.c,v
retrieving revision 1.20
diff -u -p -r1.20 tkMacOSXCarbonEvents.c
--- macosx/tkMacOSXCarbonEvents.c 19 Jun 2008 00:16:11 -0000 1.20
+++ macosx/tkMacOSXCarbonEvents.c 19 Jun 2008 00:17:40 -0000
@@ -211,6 +211,8 @@ TkMacOSXInitCarbonEvents(
{kEventClassApplication, kEventAppShown},
{kEventClassApplication, kEventAppAvailableWindowBoundsChanged},
{kEventClassAppearance, kEventAppearanceScrollBarVariantChanged},
+ {kEventClassFont, kEventFontPanelClosed},
+ {kEventClassFont, kEventFontSelection},
};
carbonEventHandlerUPP = NewEventHandlerUPP(CarbonEventHandlerProc);
Index: macosx/tkMacOSXDialog.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXDialog.c,v
retrieving revision 1.37
diff -u -p -r1.37 tkMacOSXDialog.c
--- macosx/tkMacOSXDialog.c 27 Apr 2008 22:39:12 -0000 1.37
+++ macosx/tkMacOSXDialog.c 19 Jun 2008 00:17:40 -0000
@@ -5,7 +5,7 @@
*
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
* Copyright 2001, Apple Computer, Inc.
- * Copyright (c) 2006-2007 Daniel A. Steffen <[email protected]>
+ * Copyright (c) 2006-2008 Daniel A. Steffen <[email protected]>
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -38,6 +38,7 @@
* The following structures are used in the GetFileName() function. They store
* information about the file dialog and the file filters.
*/
+
typedef struct _OpenFileData {
FileFilterList fl; /* List of file filters. */
SInt16 curType; /* The filetype currently being listed. */
@@ -1717,3 +1718,531 @@ AlertHandler(
}
return eventNotHandledErr;
}
+
+/*
+ *----------------------------------------------------------------------
+ */
+#pragma mark [tk::choosefont] implementation (TIP 213)
+/*
+ *----------------------------------------------------------------------
+ */
+
+#include "tkMacOSXEvent.h"
+#include "tkMacOSXFont.h"
+
+typedef struct ChoosefontData {
+ Tcl_Obj *titleObj;
+ Tcl_Obj *cmdObj;
+ Tk_Window parent;
+} ChoosefontData;
+
+static Tcl_Obj *ChoosefontCget(ChoosefontData *cfdPtr, int optionIndex);
+static int ChoosefontConfigureCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int ChoosefontShowCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int ChoosefontHideCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static void DeleteChoosefontData(ClientData clientData, Tcl_Interp *interp);
+
+static const TkEnsemble choosefontEnsemble[] = {
+ { "configure", ChoosefontConfigureCmd, NULL },
+ { "show", ChoosefontShowCmd, NULL },
+ { "hide", ChoosefontHideCmd, NULL },
+};
+
+static Tcl_Interp *choosefontInterp = NULL;
+static FMFontFamily fontPanelFontFamily = kInvalidFontFamily;
+static FMFontStyle fontPanelFontStyle = 0;
+static FMFontSize fontPanelFontSize = 0;
+
+static const char *choosefontOptionStrings[] = {
+ "-parent", "-title", "-font", "-command",
+ "-visible", NULL
+};
+enum ChoosefontOption {
+ ChoosefontParent, ChoosefontTitle, ChoosefontFont, ChoosefontCmd,
+ ChoosefontVisible
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkMacOSXProcessFontEvent --
+ *
+ * This processes Font panel events.
+ *
+ * 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;
+ ChoosefontData *cfdPtr;
+
+ switch (eventPtr->eKind) {
+ case kEventFontPanelClosed:
+ case kEventFontSelection:
+ break;
+ default:
+ goto done;
+ }
+ if (!choosefontInterp) {
+ goto done;
+ }
+ cfdPtr = Tcl_GetAssocData(choosefontInterp, "::tk::choosefont", NULL);
+ switch (eventPtr->eKind) {
+ case kEventFontPanelClosed:
+ if (!FPIsFontPanelVisible()) {
+ TkSendVirtualEvent(cfdPtr->parent, "TkChoosefontVisibility");
+ choosefontInterp = NULL;
+ eventGenerated = 1;
+ }
+ break;
+ case kEventFontSelection: {
+ Tcl_Obj *fontObj = NULL;
+
+ err = ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamFMFontFamily, typeFMFontFamily, NULL,
+ sizeof(FMFontFamily), NULL, &fontPanelFontFamily);
+ if (err != noErr) goto noQDFont;
+ err = ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamFMFontStyle, typeFMFontStyle, NULL,
+ sizeof(FMFontStyle), NULL, &fontPanelFontStyle);
+ if (err != noErr) goto noQDFont;
+ err = ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamFMFontSize, typeFMFontSize, NULL,
+ sizeof(FMFontSize), NULL, &fontPanelFontSize);
+ if (err != noErr) goto noQDFont;
+ fontObj = TkMacOSXFontDescriptionForFMFontInfo(
+ fontPanelFontFamily, fontPanelFontStyle,
+ fontPanelFontSize);
+ noQDFont:
+ if (err != noErr) {
+ ATSUFontID fontID;
+ Fixed fontFixedSize;
+
+ err = ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamATSUFontID, typeATSUFontID, NULL,
+ sizeof(ATSUFontID), NULL, &fontID);
+ if (err != noErr) goto noATSFont;
+ err = ChkErr(FMGetFontFamilyInstanceFromFont, fontID,
+ &fontPanelFontFamily, &fontPanelFontStyle);
+ if (err != noErr) {
+ fontPanelFontFamily = kInvalidFontFamily;
+ }
+ err = ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamATSUFontSize, typeATSUSize, NULL,
+ sizeof(Fixed), NULL, &fontFixedSize);
+ if (err != noErr) goto noATSFont;
+ fontPanelFontSize = FixedToInt(fontFixedSize);
+ if (fontPanelFontFamily != kInvalidFontFamily) {
+ fontObj = TkMacOSXFontDescriptionForFMFontInfo(
+ fontPanelFontFamily, fontPanelFontStyle,
+ fontPanelFontSize);
+ } else {
+ CFStringRef fontName;
+
+ err = ChkErr(ATSFontGetName,
+ FMGetATSFontRefFromFont(fontID),
+ kATSOptionFlagsDefault, &fontName);
+ if (err != noErr) goto noATSFont;
+ if (fontName) {
+ Tcl_Obj *objv[] = {
+ TkMacOSXGetStringObjFromCFString(fontName),
+ Tcl_NewIntObj(fontPanelFontSize)
+ };
+
+ if (objv[0]) {
+ fontObj = Tcl_NewListObj(2, objv);
+ } else {
+ Tcl_DecrRefCount(objv[1]);
+ }
+ CFRelease(fontName);
+ }
+ }
+ }
+ noATSFont:
+ if (cfdPtr->cmdObj) {
+ int objc, result;
+ Tcl_Obj **objv, **tmpv;
+
+ result = Tcl_ListObjGetElements(choosefontInterp,
+ cfdPtr->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 ? fontObj : Tcl_NewObj();
+ result = TkBackgroundEvalObjv(choosefontInterp, objc+1,
+ tmpv, TCL_EVAL_GLOBAL);
+ ckfree((char *)tmpv);
+ }
+ }
+ break;
+ }
+ }
+done:
+ return eventGenerated;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ChoosefontCget --
+ *
+ * Helper for the ChoosefontConfigure 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 *
+ChoosefontCget(ChoosefontData *cfdPtr, int optionIndex)
+{
+ Tcl_Obj *resObj = NULL;
+
+ switch(optionIndex) {
+ case ChoosefontParent: {
+ if (cfdPtr->parent != None) {
+ resObj = Tcl_NewStringObj(
+ ((TkWindow*)cfdPtr->parent)->pathName, -1);
+ } else {
+ resObj = Tcl_NewStringObj(".", 1);
+ }
+ break;
+ }
+ case ChoosefontTitle: {
+ if (cfdPtr->titleObj) {
+ resObj = cfdPtr->titleObj;
+ } else {
+ resObj = Tcl_NewObj();
+ }
+ break;
+ }
+ case ChoosefontFont: {
+ if (fontPanelFontFamily != kInvalidFontFamily) {
+ resObj = TkMacOSXFontDescriptionForFMFontInfo(
+ fontPanelFontFamily, fontPanelFontStyle,
+ fontPanelFontSize);
+ } else {
+ resObj = Tcl_NewObj();
+ }
+ break;
+ }
+ case ChoosefontCmd: {
+ if (cfdPtr->cmdObj) {
+ resObj = cfdPtr->cmdObj;
+ } else {
+ resObj = Tcl_NewObj();
+ }
+ break;
+ }
+ case ChoosefontVisible: {
+ resObj = Tcl_NewBooleanObj(FPIsFontPanelVisible());
+ break;
+ }
+ default: {
+ resObj = Tcl_NewObj();
+ }
+ }
+ return resObj;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ChoosefontConfigureCmd --
+ *
+ * Implementation of the 'tk::choosefont 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
+ChoosefontConfigureCmd(
+ ClientData clientData, /* Main window */
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tk_Window tkwin = (Tk_Window)clientData;
+ ChoosefontData *cfdPtr = Tcl_GetAssocData(interp, "::tk::choosefont",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 && choosefontOptionStrings[i] != NULL; ++i) {
+ keyObj = Tcl_NewStringObj(choosefontOptionStrings[i], -1);
+ valueObj = ChoosefontCget(cfdPtr, 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], choosefontOptionStrings,
+ "option", 0, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ /* With one option and no arg, return the current value */
+ Tcl_SetObjResult(interp, ChoosefontCget(cfdPtr, 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 ChoosefontVisible: {
+ 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 ChoosefontParent: {
+ Tk_Window parent = Tk_NameToWindow(interp,
+ Tcl_GetString(objv[i+1]), tkwin);
+ if (parent == None) {
+ return TCL_ERROR;
+ }
+ cfdPtr->parent = parent;
+ break;
+ }
+ case ChoosefontTitle:
+ if (cfdPtr->titleObj) {
+ Tcl_DecrRefCount(cfdPtr->titleObj);
+ }
+ Tcl_GetStringFromObj(objv[i+1], &len);
+ if (len) {
+ cfdPtr->titleObj = objv[i+1];
+ if (Tcl_IsShared(cfdPtr->titleObj)) {
+ cfdPtr->titleObj = Tcl_DuplicateObj(cfdPtr->titleObj);
+ }
+ Tcl_IncrRefCount(cfdPtr->titleObj);
+ } else {
+ cfdPtr->titleObj = NULL;
+ }
+ break;
+ case ChoosefontFont: {
+
+ 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);
+ }
+ break;
+ }
+ case ChoosefontCmd:
+ if (cfdPtr->cmdObj) {
+ Tcl_DecrRefCount(cfdPtr->cmdObj);
+ }
+ Tcl_GetStringFromObj(objv[i+1], &len);
+ if (len) {
+ cfdPtr->cmdObj = objv[i+1];
+ if (Tcl_IsShared(cfdPtr->cmdObj)) {
+ cfdPtr->cmdObj = Tcl_DuplicateObj(cfdPtr->cmdObj);
+ }
+ Tcl_IncrRefCount(cfdPtr->cmdObj);
+ } else {
+ cfdPtr->cmdObj = NULL;
+ }
+ break;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ChoosefontShowCmd --
+ *
+ * Implements the 'tk::choosefont 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
+ChoosefontShowCmd(
+ ClientData clientData, /* Main window */
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ ChoosefontData *cfdPtr = Tcl_GetAssocData(interp, "::tk::choosefont",NULL);
+
+ if (cfdPtr->parent == None) {
+ cfdPtr->parent = (Tk_Window) clientData;
+ }
+ if (!FPIsFontPanelVisible()) {
+ ChkErr(FPShowHideFontPanel);
+ choosefontInterp = interp;
+ TkSendVirtualEvent(cfdPtr->parent, "TkChoosefontVisibility");
+ }
+
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ChoosefontHideCmd --
+ *
+ * Implementation of the 'tk::choosefont hide' ensemble. See the
+ * user documentation for details.
+ *
+ * Results:
+ * See the user documentation.
+ *
+ * Side effects:
+ * Font Panel may be hidden.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ChoosefontHideCmd(
+ ClientData clientData, /* Main window */
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (FPIsFontPanelVisible()) {
+ ChkErr(FPShowHideFontPanel);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteChoosefontData --
+ *
+ * Clean up the font chooser configuration data when the interp
+ * is destroyed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * per-interp configuration data is destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteChoosefontData(ClientData clientData, Tcl_Interp *interp)
+{
+ ChoosefontData *cfdPtr = clientData;
+
+ if (cfdPtr->titleObj) {
+ Tcl_DecrRefCount(cfdPtr->titleObj);
+ }
+ if (cfdPtr->cmdObj) {
+ Tcl_DecrRefCount(cfdPtr->cmdObj);
+ }
+ ckfree((char *)cfdPtr);
+
+ if (choosefontInterp == interp) {
+ choosefontInterp = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TkChoosefontInit --
+ *
+ * Set up the tk::choosefont ensemble and 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
+TkChoosefontInit(Tcl_Interp *interp, ClientData clientData)
+{
+ ChoosefontData *cfdPtr = (ChoosefontData*) ckalloc(sizeof(ChoosefontData));
+
+ bzero(cfdPtr, sizeof(ChoosefontData));
+ Tcl_SetAssocData(interp, "::tk::choosefont", DeleteChoosefontData, cfdPtr);
+ TkMakeEnsemble(interp, "::tk", "choosefont", clientData,
+ choosefontEnsemble);
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 79
+ * coding: utf-8
+ * End:
+ */
Index: macosx/tkMacOSXEvent.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXEvent.c,v
retrieving revision 1.23
diff -u -p -r1.23 tkMacOSXEvent.c
--- macosx/tkMacOSXEvent.c 13 Dec 2007 15:27:09 -0000 1.23
+++ macosx/tkMacOSXEvent.c 19 Jun 2008 00:17:40 -0000
@@ -104,6 +104,9 @@ TkMacOSXProcessEvent(
case kEventClassCommand:
TkMacOSXProcessCommandEvent(eventPtr, statusPtr);
break;
+ case kEventClassFont:
+ TkMacOSXProcessFontEvent(eventPtr, statusPtr);
+ break;
default: {
TkMacOSXDbgMsg("Unrecognised event: %s",
TkMacOSXCarbonEventToAscii(eventPtr->eventRef));
Index: macosx/tkMacOSXEvent.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXEvent.h,v
retrieving revision 1.12
diff -u -p -r1.12 tkMacOSXEvent.h
--- macosx/tkMacOSXEvent.h 23 Apr 2007 21:24:33 -0000 1.12
+++ macosx/tkMacOSXEvent.h 19 Jun 2008 00:17:40 -0000
@@ -98,6 +98,8 @@ MODULE_SCOPE int TkMacOSXProcessMenuEven
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,
Index: macosx/tkMacOSXFont.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXFont.c,v
retrieving revision 1.38
diff -u -p -r1.38 tkMacOSXFont.c
--- macosx/tkMacOSXFont.c 19 Jun 2008 00:10:24 -0000 1.38
+++ macosx/tkMacOSXFont.c 19 Jun 2008 00:17:41 -0000
@@ -2439,6 +2439,86 @@ 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE Tcl_Obj *
+TkMacOSXFontDescriptionForFMFontInfo(
+ FMFontFamily fontFamily,
+ FMFontStyle fontStyle,
+ FMFontSize fontSize)
+{
+ const char *familyName;
+ Tcl_Obj *objv[6];
+ int i = 0;
+
+ 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
+ }
+ return Tcl_NewListObj(i, objv);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TkMacOSXUseAntialiasedText --
*
* Enables or disables application-wide use of antialiased text (where
Index: macosx/tkMacOSXFont.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXFont.h,v
retrieving revision 1.5
diff -u -p -r1.5 tkMacOSXFont.h
--- macosx/tkMacOSXFont.h 23 Apr 2007 21:24:33 -0000 1.5
+++ macosx/tkMacOSXFont.h 19 Jun 2008 00:17:41 -0000
@@ -30,5 +30,10 @@
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);
#endif /*TKMACOSXFONT_H*/
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 19 Jun 2008 00:17:41 -0000
@@ -0,0 +1,202 @@
+# Test the "tk::choosefont" command
+#
+# Copyright (c) 2008 Pat Thoyts
+#
+# RCS: @(#) $Id$
+#
+
+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).
+
+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 -parent . -font
+} -result {value for "-font" missing}
+
+test fontdlg-1.4 {tk::choosefont: usage} -returnCodes error -body {
+ tk::choosefont configure -parent . -title
+} -result {value for "-title" missing}
+
+test fontdlg-1.5 {tk::choosefont: usage} -returnCodes error -body {
+ tk::choosefont configure -parent . -command
+} -result {value for "-command" missing}
+
+test fontdlg-1.6 {tk::choosefont: usage} -returnCodes error -body {
+ tk::choosefont configure -title . -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"}
+
+test fontdlg-1.8 {tk::choosefont: usage} -returnCodes ok -body {
+ tk::choosefont configure -visible
+} -result {0}
+
+test fontdlg-1.9 {tk::choosefont: usage} -returnCodes error -body {
+ tk::choosefont 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.
+
+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:
Index: tests/winDialog.test
===================================================================
RCS file: /cvsroot/tktoolkit/tk/tests/winDialog.test,v
retrieving revision 1.17
diff -u -p -r1.17 winDialog.test
--- tests/winDialog.test 13 May 2008 12:39:28 -0000 1.17
+++ tests/winDialog.test 19 Jun 2008 00:17:41 -0000
@@ -27,6 +27,7 @@ proc start {arg} {
proc then {cmd} {
set ::command $cmd
set ::dialogresult {}
+ set ::testfont {}
afterbody
vwait ::dialogresult
@@ -58,6 +59,10 @@ proc SetText {button text} {
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 @@ test winDialog-9.8 {Tk_ChooseDirectoryOb
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 -p -r1.52 tkWinDialog.c
--- win/tkWinDialog.c 27 Apr 2008 22:39:14 -0000 1.52
+++ win/tkWinDialog.c 19 Jun 2008 00:17:42 -0000
@@ -14,6 +14,7 @@
#include "tkWinInt.h"
#include "tkFileFilter.h"
+#include "tkFont.h"
#include <commdlg.h> /* includes common dialog functionality */
#ifdef _MSC_VER
@@ -2257,6 +2258,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)
@@ -2295,6 +2309,515 @@ 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, "TkChoosefontVisibility");
+ return 1; /* we handled the message */
+ }
+
+ if (WM_DESTROY == msg) {
+ phd->hwnd = NULL;
+ TkSendVirtualEvent(phd->parent, "TkChoosefontVisibility");
+ 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);
+ }
+ return 1;
+ }
+ return 0; /* pass on for default processing */
+}
+
+/*
+ * Helper for the ChoosefontConfigure command to return the
+ * current value of any of the options (which may be NULL in
+ * the structure)
+ */
+
+enum ChoosefontOption {
+ ChooseFontParent, ChooseFontTitle, ChooseFontFont, ChooseFontCmd,
+ ChooseFontVisible
+};
+
+static Tcl_Obj *
+ChoosefontCget(HookData *hdPtr, int optionIndex)
+{
+ Tcl_Obj *resObj = NULL;
+ switch(optionIndex) {
+ case ChooseFontParent: {
+ if (hdPtr->parentObj) {
+ resObj = hdPtr->parentObj;
+ } else {
+ resObj = Tcl_NewStringObj(".", 1);
+ }
+ break;
+ }
+ case ChooseFontTitle: {
+ if (hdPtr->titleObj) {
+ resObj = hdPtr->titleObj;
+ } else {
+ resObj = Tcl_NewStringObj("", 0);
+ }
+ break;
+ }
+ case ChooseFontFont: {
+ if (hdPtr->fontObj) {
+ resObj = hdPtr->fontObj;
+ } else {
+ resObj = Tcl_NewStringObj("", 0);
+ }
+ break;
+ }
+ case ChooseFontCmd: {
+ if (hdPtr->cmdObj) {
+ resObj = hdPtr->cmdObj;
+ } else {
+ resObj = Tcl_NewStringObj("", 0);
+ }
+ break;
+ }
+ case ChooseFontVisible: {
+ resObj = Tcl_NewBooleanObj(hdPtr->hwnd && IsWindow(hdPtr->hwnd));
+ break;
+ }
+ default: {
+ resObj = Tcl_NewStringObj("", 0);
+ }
+ }
+ return resObj;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tk_ChooseFontObjCmd --
+ *
+ * Implementation of the 'tk::choosefont 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
+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, r = TCL_OK;
+ static const char *optionStrings[] = {
+ "-parent", "-title", "-font", "-command", "-visible", NULL
+ };
+
+ hdPtr = Tcl_GetAssocData(interp, "::tk::choosefont", 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 = ChoosefontCget(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, ChoosefontCget(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 ChooseFontVisible: {
+ 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 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;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ChoosefontShowCmd --
+ *
+ * Implements the 'tk::choosefont show' ensemble command. The
+ * per-interp configuration data for the dialog is held in an interp
+ * associated structure.
+ * Calls the Win32 ChooseFont API which provides a modal dialog.
+ * See HookProc where we make a few changes to the dialog and set
+ * some additional state.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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;
+ 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 (ChooseFont(&cf) && hdPtr->cmdObj) {
+ ApplyLogfont(hdPtr->interp, hdPtr->cmdObj, hdc, &lf);
+ }
+ Tcl_SetServiceMode(oldMode);
+ EnableWindow(cf.hwndOwner, 1);
+ }
+
+ ReleaseDC(cf.hwndOwner, hdc);
+
+ return r;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ChoosefontHideCmd --
+ *
+ * Implementation of the 'tk::choosefont hide' ensemble. See the
+ * user documentation for details.
+ * As the Win32 ChooseFont function is always modal all we do here
+ * is destroy the dialog
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TkChoosefontInit --
+ *
+ * Set up the tk::choosefont ensemble and associate the font chooser
+ * configuration data with the Tcl interpreter. There is one
+ * font chooser per interp.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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
Index: win/tkWinInt.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinInt.h,v
retrieving revision 1.31
diff -u -p -r1.31 tkWinInt.h
--- win/tkWinInt.h 14 Dec 2007 15:56:09 -0000 1.31
+++ win/tkWinInt.h 19 Jun 2008 00:17:42 -0000
@@ -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;
Index: win/tkWinTest.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinTest.c,v
retrieving revision 1.17
diff -u -p -r1.17 tkWinTest.c
--- win/tkWinTest.c 27 Apr 2008 22:39:17 -0000 1.17
+++ win/tkWinTest.c 19 Jun 2008 00:17:42 -0000
@@ -381,18 +381,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));
@@ -401,6 +408,9 @@ TestfindwindowObjCmd(
} else {
Tcl_SetObjResult(interp, Tcl_NewLongObj((long)hwnd));
}
+
+ Tcl_DStringFree(&titleString);
+ Tcl_DStringFree(&classString);
return r;
}
@@ -421,7 +431,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;
@@ -434,25 +444,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;
- }
-
- 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,
+ } else {
+ Tcl_DString ds;
+ Tcl_WinTCharToUtf(buf, -1, &ds);
+ classObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
+
+ 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);
@@ -462,18 +468,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;
}
Index: win/tkWinX.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinX.c,v
retrieving revision 1.58
diff -u -p -r1.58 tkWinX.c
--- win/tkWinX.c 27 Apr 2008 22:39:17 -0000 1.58
+++ win/tkWinX.c 19 Jun 2008 00:17:43 -0000
@@ -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;
