TIP #324 IMPLEMENTATION

3 files changed, 131 insertions, 7 deletions

diff --git a/generic/tkCmds.c b/generic/tkCmds.c
index 49d1f38..21bd8d4 100644
--- a/generic/tkCmds.c
+++ b/generic/tkCmds.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkCmds.c,v 1.48 2008/12/10 00:34:51 das Exp $
+ * RCS: @(#) $Id: tkCmds.c,v 1.49 2008/12/10 05:02:40 das Exp $
  */
 
 #include "tkInt.h"
@@ -51,6 +51,12 @@ static int		WindowingsystemCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
 
+#if defined(__WIN32__) || defined(MAC_OSX_TK)
+MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[];
+#else
+#define tkFontchooserEnsemble NULL
+#endif
+
 /*
  * Table of tk subcommand names and implementations.
  */
@@ -63,6 +69,7 @@ static const TkEnsemble tkCmdMap[] = {
     {"scaling",		ScalingCmd },
     {"useinputmethods",	UseinputmethodsCmd },
     {"windowingsystem",	WindowingsystemCmd },
+    {"fontchooser",	NULL, tkFontchooserEnsemble},
     {NULL}
 };
 
@@ -635,6 +642,9 @@ int
 TkInitTkCmd(Tcl_Interp *interp, ClientData clientData)
 {
     TkMakeEnsemble(interp, "::", "tk", clientData, tkCmdMap);
+#if defined(__WIN32__) || defined(MAC_OSX_TK)
+    TkInitFontchooser(interp, clientData);
+#endif
     return TCL_OK;
 }
 
diff --git a/generic/tkInt.h b/generic/tkInt.h
index 7131bb7..214b428 100644
--- a/generic/tkInt.h
+++ b/generic/tkInt.h
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: $Id: tkInt.h,v 1.97 2008/12/10 00:34:51 das Exp $
+ * RCS: $Id: tkInt.h,v 1.98 2008/12/10 05:02:51 das Exp $
  */
 
 #ifndef _TKINT
@@ -1040,9 +1040,6 @@ MODULE_SCOPE int	Tk_ChooseColorObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tk_ChooseDirectoryObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
-MODULE_SCOPE int	Tk_ChooseFontObjCmd(ClientData clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tk_DestroyObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -1251,7 +1248,6 @@ MODULE_SCOPE void	TkpMakeTransparentWindowExist(Tk_Window tkwin,
 MODULE_SCOPE void	TkpCreateBusy(Tk_FakeWin *winPtr, Tk_Window tkRef,
 			    Window *parentPtr, Tk_Window tkParent,
 			    TkBusy busy);
-
 MODULE_SCOPE void	TkDrawAngledTextLayout(Display *display,
 			    Drawable drawable, GC gc, Tk_TextLayout layout,
 			    int x, int y, double angle, int firstChar,
@@ -1264,11 +1260,16 @@ MODULE_SCOPE void	TkUnderlineAngledTextLayout(Display *display,
 			    int x, int y, double angle, int underline);
 MODULE_SCOPE int	TkIntersectAngledTextLayout(Tk_TextLayout layout,
 			    int x,int y, int width, int height, double angle);
+MODULE_SCOPE int	TkBackgroundEvalObjv(Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const *objv, int flags);
+MODULE_SCOPE void	TkSendVirtualEvent(Tk_Window tgtWin, const char *eventName);
 MODULE_SCOPE Tcl_Command TkMakeEnsemble(Tcl_Interp *interp,
 			    const char *namespace, const char *name,
 			    ClientData clientData, const TkEnsemble *map);
 MODULE_SCOPE int	TkInitTkCmd(Tcl_Interp *interp,
 			    ClientData clientData);
+MODULE_SCOPE int	TkInitFontchooser(Tcl_Interp *interp,
+			    ClientData clientData);
 
 /*
  * Unsupported commands.
diff --git a/generic/tkUtil.c b/generic/tkUtil.c
index 8cfaf9a..5218740 100644
--- a/generic/tkUtil.c
+++ b/generic/tkUtil.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkUtil.c,v 1.26 2008/12/10 04:27:45 das Exp $
+ * RCS: @(#) $Id: tkUtil.c,v 1.27 2008/12/10 05:02:51 das Exp $
  */
 
 #include "tkInt.h"
@@ -978,6 +978,89 @@ TkFindStateNumObj(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TkBackgroundEvalObjv --
+ *
+ *	Evaluate a command while ensuring that we do not affect the
+ *	interpreters state. This is important when evaluating script
+ *	during background tasks.
+ *
+ * Results:
+ *	A standard Tcl result code.
+ *
+ * Side Effects:
+ *	The interpreters variables and code may be modified by the script
+ *	but the result will not be modified.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TkBackgroundEvalObjv(
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv,
+    int flags)
+{
+    Tcl_DString errorInfo, errorCode;
+    Tcl_SavedResult state;
+    int n, r = TCL_OK;
+
+    Tcl_DStringInit(&errorInfo);
+    Tcl_DStringInit(&errorCode);
+
+    Tcl_Preserve(interp);
+
+    /*
+     * Record the state of the interpreter
+     */
+
+    Tcl_SaveResult(interp, &state);
+    Tcl_DStringAppend(&errorInfo,
+	Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1);
+    Tcl_DStringAppend(&errorCode,
+	Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY), -1);
+
+    /*
+     * Evaluate the command and handle any error.
+     */
+
+    for (n = 0; n < objc; ++n) {
+	Tcl_IncrRefCount(objv[n]);
+    }
+    r = Tcl_EvalObjv(interp, objc, objv, flags);
+    for (n = 0; n < objc; ++n) {
+	Tcl_DecrRefCount(objv[n]);
+    }
+    if (r == TCL_ERROR) {
+        Tcl_AddErrorInfo(interp, "\n    (background event handler)");
+        Tcl_BackgroundError(interp);
+    }
+
+    Tcl_Release(interp);
+
+    /*
+     * Restore the state of the interpreter
+     */
+
+    Tcl_SetVar(interp, "errorInfo",
+	Tcl_DStringValue(&errorInfo), TCL_GLOBAL_ONLY);
+    Tcl_SetVar(interp, "errorCode",
+	Tcl_DStringValue(&errorCode), TCL_GLOBAL_ONLY);
+    Tcl_RestoreResult(interp, &state);
+
+    /*
+     * Clean up references.
+     */
+
+    Tcl_DStringFree(&errorInfo);
+    Tcl_DStringFree(&errorCode);
+
+    return r;
+}
+
+/*
  *----------------------------------------------------------------------
  *
  * TkMakeEnsemble --
@@ -1060,6 +1143,36 @@ TkMakeEnsemble(
     Tcl_DStringFree(&ds);
     return ensemble;
 }
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkSendVirtualEvent --
+ *
+ * 	Send a virtual event notification to the specified target window.
+ * 	Equivalent to "event generate $target <<$eventName>>"
+ *
+ * 	Note that we use Tk_QueueWindowEvent, not Tk_HandleEvent,
+ * 	so this routine does not reenter the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TkSendVirtualEvent(Tk_Window target, const char *eventName)
+{
+    XEvent event;
+
+    memset(&event, 0, sizeof(event));
+    event.xany.type = VirtualEvent;
+    event.xany.serial = NextRequest(Tk_Display(target));
+    event.xany.send_event = False;
+    event.xany.window = Tk_WindowId(target);
+    event.xany.display = Tk_Display(target);
+    ((XVirtualEvent *) &event)->name = Tk_GetUid(eventName);
+
+    Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL);
+}
 /*
  * Local Variables:
  * mode: c