TIP #324 IMPLEMENTATION

1 files changed, 565 insertions, 2 deletions

diff --git a/macosx/tkMacOSXDialog.c b/macosx/tkMacOSXDialog.c
index 1553592..e283f5c 100644
--- a/macosx/tkMacOSXDialog.c
+++ b/macosx/tkMacOSXDialog.c
@@ -5,12 +5,12 @@
  *
  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
  * Copyright 2001, Apple Computer, Inc.
- * Copyright (c) 2006-2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2006-2008 Daniel A. Steffen <das@users.sourceforge.net>
  *
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkMacOSXDialog.c,v 1.42 2008/12/07 16:36:26 das Exp $
+ * RCS: @(#) $Id: tkMacOSXDialog.c,v 1.43 2008/12/10 05:02:52 das Exp $
  */
 
 #include "tkMacOSXPrivate.h"
@@ -1741,3 +1741,566 @@ AlertHandler(
     }
     return eventNotHandledErr;
 }
+
+/*
+ *----------------------------------------------------------------------
+ */
+#pragma mark [tk fontchooser] implementation (TIP 324)
+/*
+ *----------------------------------------------------------------------
+ */
+
+#include "tkMacOSXEvent.h"
+#include "tkMacOSXFont.h"
+
+typedef struct FontchooserData {
+    Tcl_Obj *titleObj;
+    Tcl_Obj *cmdObj;
+    Tk_Window parent;
+} FontchooserData;
+
+static Tcl_Obj *FontchooserCget(FontchooserData *fcdPtr, int optionIndex);
+static int FontchooserConfigureCmd(ClientData clientData, Tcl_Interp *interp,
+	int objc, Tcl_Obj *const objv[]);
+static int FontchooserShowCmd(ClientData clientData, Tcl_Interp *interp,
+	int objc, Tcl_Obj *const objv[]);
+static int FontchooserHideCmd(ClientData clientData, Tcl_Interp *interp,
+	int objc, Tcl_Obj *const objv[]);
+static void FontchooserParentEventHandler(ClientData clientData,
+	XEvent *eventPtr);
+static void DeleteFontchooserData(ClientData clientData, Tcl_Interp *interp);
+
+MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[];
+const TkEnsemble tkFontchooserEnsemble[] = {
+    { "configure", FontchooserConfigureCmd },
+    { "show", FontchooserShowCmd },
+    { "hide", FontchooserHideCmd },
+};
+
+static Tcl_Interp *fontchooserInterp = NULL;
+static FMFontFamily fontPanelFontFamily = kInvalidFontFamily;
+static FMFontStyle fontPanelFontStyle = -1;
+static FMFontSize fontPanelFontSize = 0;
+static FMFont fontPanelFontID = kInvalidFont;
+
+static const char *fontchooserOptionStrings[] = {
+    "-parent", "-title", "-font", "-command",
+    "-visible", NULL
+};
+enum FontchooserOption {
+    FontchooserParent, FontchooserTitle, FontchooserFont, FontchooserCmd,
+    FontchooserVisible
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkMacOSXProcessFontEvent --
+ *
+ *	This processes events generated by user interaction with the
+ *	font panel.
+ *
+ * Results:
+ *	True if Tk events are generated - false otherwise.
+ *
+ * Side effects:
+ *	Additional events may be place on the Tk event queue.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE int
+TkMacOSXProcessFontEvent(
+    TkMacOSXEvent * eventPtr,
+    MacEventStatus * statusPtr)
+{
+    OSStatus err;
+    int eventGenerated = 0;
+    FontchooserData *fcdPtr;
+
+    switch (eventPtr->eKind) {
+	case kEventFontPanelClosed:
+	case kEventFontSelection:
+	    break;
+	default:
+	    goto done;
+    }
+    if (!fontchooserInterp) {
+	goto done;
+    }
+    fcdPtr = Tcl_GetAssocData(fontchooserInterp, "::tk::fontchooser", NULL);
+    switch (eventPtr->eKind) {
+	case kEventFontPanelClosed:
+	    if (!FPIsFontPanelVisible() && fcdPtr->parent != None) {
+		TkSendVirtualEvent(fcdPtr->parent, "TkFontchooserVisibility");
+		fontchooserInterp = NULL;
+		eventGenerated = 1;
+	    }
+	    break;
+	case kEventFontSelection: {
+	    Tcl_Obj *fontObj = NULL;
+
+	    fontPanelFontFamily = kInvalidFontFamily;
+	    fontPanelFontStyle = -1;
+	    fontPanelFontSize = 0;
+	    fontPanelFontID = kInvalidFont;
+	    err = ChkErr(GetEventParameter, eventPtr->eventRef,
+		    kEventParamFMFontFamily, typeFMFontFamily, NULL,
+		    sizeof(FMFontFamily), NULL, &fontPanelFontFamily);
+	    err |= ChkErr(GetEventParameter, eventPtr->eventRef,
+		    kEventParamFMFontStyle, typeFMFontStyle, NULL,
+		    sizeof(FMFontStyle), NULL, &fontPanelFontStyle);
+	    err |= ChkErr(GetEventParameter, eventPtr->eventRef,
+		    kEventParamFMFontSize, typeFMFontSize, NULL,
+		    sizeof(FMFontSize), NULL, &fontPanelFontSize);
+	    if (err != noErr) {
+		/*
+		 * No/incomplete QD font spec, use ATSUI font ID
+		 */
+		Fixed fontFixedSize;
+
+		err = ChkErr(GetEventParameter, eventPtr->eventRef,
+			kEventParamATSUFontID, typeATSUFontID, NULL,
+			sizeof(ATSUFontID), NULL, &fontPanelFontID);
+		if (err == noErr) {
+		    ChkErr(FMGetFontFamilyInstanceFromFont, fontPanelFontID,
+			    &fontPanelFontFamily, &fontPanelFontStyle);
+		}
+		err = ChkErr(GetEventParameter, eventPtr->eventRef,
+			kEventParamATSUFontSize, typeATSUSize, NULL,
+			sizeof(Fixed), NULL, &fontFixedSize);
+		if (err == noErr) {
+		    fontPanelFontSize = FixedToInt(fontFixedSize);
+		}
+	    }
+	    fontObj = TkMacOSXFontDescriptionForFMFontInfo(
+		fontPanelFontFamily, fontPanelFontStyle,
+		fontPanelFontSize, fontPanelFontID);
+	    if (fontObj) {
+		if (fcdPtr->cmdObj) {
+		    int objc, result;
+		    Tcl_Obj **objv, **tmpv;
+
+		    result = Tcl_ListObjGetElements(fontchooserInterp,
+			    fcdPtr->cmdObj, &objc, &objv);
+		    if (result == TCL_OK) {
+			tmpv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) *
+				(unsigned)(objc + 2));
+			memcpy(tmpv, objv, sizeof(Tcl_Obj *) * objc);
+			tmpv[objc] = fontObj;
+			result = TkBackgroundEvalObjv(fontchooserInterp,
+				objc + 1, tmpv, TCL_EVAL_GLOBAL);
+			ckfree((char *)tmpv);
+		    }
+		}
+		TkSendVirtualEvent(fcdPtr->parent, "TkFontchooserFontChanged");
+	    }
+	    break;
+	}
+    }
+done:
+    return eventGenerated;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FontchooserCget --
+ *
+ *	Helper for the FontchooserConfigure command to return the
+ *	current value of any of the options (which may be NULL in
+ *	the structure)
+ *
+ * Results:
+ *	Tcl object of option value.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+FontchooserCget(
+    FontchooserData *fcdPtr,
+    int optionIndex)
+{
+    Tcl_Obj *resObj = NULL;
+
+    switch(optionIndex) {
+	case FontchooserParent: {
+	    if (fcdPtr->parent != None) {
+		resObj = Tcl_NewStringObj(
+			((TkWindow*)fcdPtr->parent)->pathName, -1);
+	    } else {
+		resObj = Tcl_NewStringObj(".", 1);
+	    }
+	    break;
+	}
+	case FontchooserTitle: {
+	    if (fcdPtr->titleObj) {
+		resObj = fcdPtr->titleObj;
+	    } else {
+		resObj = Tcl_NewObj();
+	    }
+	    break;
+	}
+	case FontchooserFont: {
+	    resObj = TkMacOSXFontDescriptionForFMFontInfo(
+		fontPanelFontFamily, fontPanelFontStyle,
+		fontPanelFontSize, fontPanelFontID);
+	    if (!resObj) {
+		resObj = Tcl_NewObj();
+	    }
+	    break;
+	}
+	case FontchooserCmd: {
+	    if (fcdPtr->cmdObj) {
+		resObj = fcdPtr->cmdObj;
+	    } else {
+		resObj = Tcl_NewObj();
+	    }
+	    break;
+	}
+	case FontchooserVisible: {
+	    resObj = Tcl_NewBooleanObj(FPIsFontPanelVisible());
+	    break;
+	}
+	default: {
+	    resObj = Tcl_NewObj();
+	}
+    }
+    return resObj;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserConfigureCmd --
+ *
+ *	Implementation of the 'tk fontchooser configure' ensemble command.
+ *	See the user documentation for what it does.
+ *
+ * Results:
+ *	See the user documentation.
+ *
+ * Side effects:
+ *	Per-interp data structure may be modified
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserConfigureCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tk_Window tkwin = (Tk_Window)clientData;
+    FontchooserData *fcdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser",
+	    NULL);
+    int i, r = TCL_OK;
+
+    /*
+     * With no arguments we return all the options in a dict
+     */
+
+    if (objc == 1) {
+	Tcl_Obj *keyObj, *valueObj;
+	Tcl_Obj *dictObj = Tcl_NewDictObj();
+	for (i = 0; r == TCL_OK && fontchooserOptionStrings[i] != NULL; ++i) {
+	    keyObj = Tcl_NewStringObj(fontchooserOptionStrings[i], -1);
+	    valueObj = FontchooserCget(fcdPtr, i);
+	    r = Tcl_DictObjPut(interp, dictObj, keyObj, valueObj);
+	}
+	if (r == TCL_OK) {
+	    Tcl_SetObjResult(interp, dictObj);
+	}
+	return r;
+    }
+
+    for (i = 1; i < objc; i += 2) {
+	int optionIndex, len;
+	if (Tcl_GetIndexFromObj(interp, objv[i], fontchooserOptionStrings,
+		"option", 0, &optionIndex) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (objc == 2) {
+	    /* With one option and no arg, return the current value */
+	    Tcl_SetObjResult(interp, FontchooserCget(fcdPtr, optionIndex));
+	    return TCL_OK;
+	}
+	if (i + 1 == objc) {
+	    Tcl_AppendResult(interp, "value for \"",
+		Tcl_GetString(objv[i]), "\" missing", NULL);
+	    return TCL_ERROR;
+	}
+	switch (optionIndex) {
+	    case FontchooserVisible: {
+		const char *msg = "cannot change read-only option "
+		    "\"-visible\": use the show or hide command";
+
+		Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, sizeof(msg)-1));
+		return TCL_ERROR;
+	    }
+	    case FontchooserParent: {
+		Tk_Window parent = Tk_NameToWindow(interp,
+		    Tcl_GetString(objv[i+1]), tkwin);
+		if (parent == None) {
+		    return TCL_ERROR;
+		}
+		if (fcdPtr->parent) {
+		    Tk_DeleteEventHandler(fcdPtr->parent, StructureNotifyMask,
+			    FontchooserParentEventHandler, fcdPtr);
+		}
+		fcdPtr->parent = parent;
+		Tk_CreateEventHandler(fcdPtr->parent, StructureNotifyMask,
+			FontchooserParentEventHandler, fcdPtr);
+		break;
+	    }
+	    case FontchooserTitle:
+		if (fcdPtr->titleObj) {
+		    Tcl_DecrRefCount(fcdPtr->titleObj);
+		}
+		Tcl_GetStringFromObj(objv[i+1], &len);
+		if (len) {
+		    fcdPtr->titleObj = objv[i+1];
+		    if (Tcl_IsShared(fcdPtr->titleObj)) {
+			fcdPtr->titleObj = Tcl_DuplicateObj(fcdPtr->titleObj);
+		    }
+		    Tcl_IncrRefCount(fcdPtr->titleObj);
+		} else {
+		    fcdPtr->titleObj = NULL;
+		}
+		break;
+	    case FontchooserFont: {
+
+		Tcl_GetStringFromObj(objv[i+1], &len);
+		if (len) {
+		    Tk_Font f = Tk_AllocFontFromObj(interp, tkwin, objv[i+1]);
+		    if (f) {
+			ATSUStyle atsuStyle;
+
+			TkMacOSXFMFontInfoForFont(f, &fontPanelFontFamily,
+				 &fontPanelFontStyle, &fontPanelFontSize,
+				 &atsuStyle);
+			ChkErr(SetFontInfoForSelection,
+				kFontSelectionATSUIType, 1, &atsuStyle, NULL);
+			Tk_FreeFont(f);
+		    } else {
+			return TCL_ERROR;
+		    }
+		} else {
+		    fontPanelFontFamily = kInvalidFontFamily;
+		    ChkErr(SetFontInfoForSelection,
+			    kFontSelectionATSUIType, 0, NULL, NULL);
+		}
+		if (FPIsFontPanelVisible()) {
+		    TkSendVirtualEvent(fcdPtr->parent,
+			    "TkFontchooserFontChanged");
+		}
+		break;
+	    }
+	    case FontchooserCmd:
+		if (fcdPtr->cmdObj) {
+		    Tcl_DecrRefCount(fcdPtr->cmdObj);
+		}
+		Tcl_GetStringFromObj(objv[i+1], &len);
+		if (len) {
+		    fcdPtr->cmdObj = objv[i+1];
+		    if (Tcl_IsShared(fcdPtr->cmdObj)) {
+			fcdPtr->cmdObj = Tcl_DuplicateObj(fcdPtr->cmdObj);
+		    }
+		    Tcl_IncrRefCount(fcdPtr->cmdObj);
+		} else {
+		    fcdPtr->cmdObj = NULL;
+		}
+		break;
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserShowCmd --
+ *
+ *	Implements the 'tk fontchooser show' ensemble command. The
+ *	per-interp configuration data for the dialog is held in an interp
+ *	associated structure.
+ *
+ * Results:
+ *	See the user documentation.
+ *
+ * Side effects:
+ *	Font Panel may be shown.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserShowCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    FontchooserData *fcdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser",
+	    NULL);
+
+    if (fcdPtr->parent == None) {
+	fcdPtr->parent = (Tk_Window) clientData;
+	Tk_CreateEventHandler(fcdPtr->parent, StructureNotifyMask,
+		FontchooserParentEventHandler, fcdPtr);
+    }
+    if (!FPIsFontPanelVisible()) {
+	ChkErr(FPShowHideFontPanel);
+	TkSendVirtualEvent(fcdPtr->parent, "TkFontchooserVisibility");
+    }
+    fontchooserInterp = interp;
+
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserHideCmd --
+ *
+ *	Implementation of the 'tk fontchooser hide' ensemble. See the
+ *	user documentation for details.
+ *
+ * Results:
+ *	See the user documentation.
+ *
+ * Side effects:
+ *	Font Panel may be hidden.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserHideCmd(
+    ClientData clientData,	/* Main window */
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    if (FPIsFontPanelVisible()) {
+	ChkErr(FPShowHideFontPanel);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserParentEventHandler --
+ *
+ *	Event handler for StructureNotify events on the font chooser's
+ *	parent window.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Font chooser parent info is cleared and font panel is hidden.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+FontchooserParentEventHandler(
+    ClientData clientData,
+    XEvent *eventPtr)
+{
+    FontchooserData *fcdPtr = clientData;
+
+    if (eventPtr->type == DestroyNotify) {
+	Tk_DeleteEventHandler(fcdPtr->parent, StructureNotifyMask,
+		FontchooserParentEventHandler, fcdPtr);
+	fcdPtr->parent = None;
+	if (FPIsFontPanelVisible()) {
+	    ChkErr(FPShowHideFontPanel);
+	}
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteFontchooserData --
+ *
+ *	Clean up the font chooser configuration data when the interp
+ *	is destroyed.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	per-interp configuration data is destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteFontchooserData(
+    ClientData clientData,
+    Tcl_Interp *interp)
+{
+    FontchooserData *fcdPtr = clientData;
+
+    if (fcdPtr->titleObj) {
+	Tcl_DecrRefCount(fcdPtr->titleObj);
+    }
+    if (fcdPtr->cmdObj) {
+	Tcl_DecrRefCount(fcdPtr->cmdObj);
+    }
+    ckfree((char *)fcdPtr);
+
+    if (fontchooserInterp == interp) {
+	fontchooserInterp = NULL;
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TkInitFontchooser --
+ *
+ *	Associate the font chooser configuration data with the Tcl
+ *	interpreter. There is one font chooser per interp.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	per-interp configuration data is destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE int
+TkInitFontchooser(
+    Tcl_Interp *interp,
+    ClientData clientData)
+{
+    FontchooserData *fcdPtr = (FontchooserData*)
+	    ckalloc(sizeof(FontchooserData));
+
+    bzero(fcdPtr, sizeof(FontchooserData));
+    Tcl_SetAssocData(interp, "::tk::fontchooser", DeleteFontchooserData,
+	    fcdPtr);
+    return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 79
+ * coding: utf-8
+ * End:
+ */