TIP #145 implementation

9 files changed, 250 insertions, 44 deletions

diff --git a/ChangeLog b/ChangeLog
index 8c9c5fc..f5a3c02 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2007-05-04  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* generic/tkFont.c:     TIP #145 implementation -
+	* generic/tkFont.h:     Enhanced font handling.
+	* win/tkWinDefault.h:
+	* win/tkWinFont.c:
+	* win/tkWinInt.h:
+	* win/tkWinWm.c:
+	* library/demos/widget:
+	* library/ttk/fonts.tcl:
+
 2007-05-04  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
 	* doc/ttk_treeview.n, doc/ttk_panedwindow.n, doc/ttk_dialog.n: 
diff --git a/generic/tkFont.c b/generic/tkFont.c
index 217efaa..14fe799 100644
--- a/generic/tkFont.c
+++ b/generic/tkFont.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: tkFont.c,v 1.33 2007/04/17 14:32:28 dkf Exp $
+ * RCS: @(#) $Id: tkFont.c,v 1.34 2007/05/04 21:29:22 patthoyts Exp $
  */
 
 #include "tkPort.h"
@@ -326,8 +326,6 @@ static char *globalFontClass[] = {
 static int		ConfigAttributesObj(Tcl_Interp *interp,
 			    Tk_Window tkwin, int objc, Tcl_Obj *const objv[],
 			    TkFontAttributes *faPtr);
-static int		CreateNamedFont(Tcl_Interp *interp, Tk_Window tkwin,
-			    const char *name, TkFontAttributes *faPtr);
 static void		DupFontObjProc(Tcl_Obj *srcObjPtr, Tcl_Obj *dupObjPtr);
 static int		FieldSpecified(const char *field);
 static void		FreeFontObjProc(Tcl_Obj *objPtr);
@@ -677,7 +675,7 @@ Tk_FontObjCmd(
 		&fa) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (CreateNamedFont(interp, tkwin, name, &fa) != TCL_OK) {
+	if (TkCreateNamedFont(interp, tkwin, name, &fa) != TCL_OK) {
 	    return TCL_ERROR;
 	}
 	Tcl_AppendResult(interp, name, NULL);
@@ -686,8 +684,6 @@ Tk_FontObjCmd(
     case FONT_DELETE: {
 	int i;
 	char *string;
-	NamedFont *nfPtr;
-	Tcl_HashEntry *namedHashPtr;
 
 	/*
 	 * Delete the named font. If there are still widgets using this font,
@@ -700,19 +696,7 @@ Tk_FontObjCmd(
 	}
 	for (i = 2; i < objc; i++) {
 	    string = Tcl_GetString(objv[i]);
-	    namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, string);
-	    if (namedHashPtr == NULL) {
-		Tcl_AppendResult(interp, "named font \"", string,
-			"\" doesn't exist", NULL);
-		return TCL_ERROR;
-	    }
-	    nfPtr = (NamedFont *) Tcl_GetHashValue(namedHashPtr);
-	    if (nfPtr->refCount != 0) {
-		nfPtr->deletePending = 1;
-	    } else {
-		Tcl_DeleteHashEntry(namedHashPtr);
-		ckfree((char *) nfPtr);
-	    }
+	    TkDeleteNamedFont(interp, tkwin, string);
 	}
 	break;
     }
@@ -936,7 +920,7 @@ RecomputeWidgets(
 /*
  *---------------------------------------------------------------------------
  *
- * CreateNamedFont --
+ * TkCreateNamedFont --
  *
  *	Create the specified named font with the given attributes in the named
  *	font table associated with the interp.
@@ -957,8 +941,8 @@ RecomputeWidgets(
  *---------------------------------------------------------------------------
  */
 
-static int
-CreateNamedFont(
+int
+TkCreateNamedFont(
     Tcl_Interp *interp,		/* Interp for error return. */
     Tk_Window tkwin,		/* A window associated with interp. */
     const char *name,		/* Name for the new named font. */
@@ -1006,6 +990,45 @@ CreateNamedFont(
 /*
  *---------------------------------------------------------------------------
  *
+ * TkDeleteNamedFont --
+ *
+ *	Delete the named font.  If there are still widgets using this
+ *	font, then it isn't deleted right away.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TkDeleteNamedFont(
+    Tcl_Interp *interp,		/* Interp for error return. */
+    Tk_Window tkwin,		/* A window associated with interp. */
+    CONST char *name)		/* Name for the new named font. */
+{
+    TkFontInfo *fiPtr;
+    NamedFont *nfPtr;
+    Tcl_HashEntry *namedHashPtr;
+    
+    fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr;
+
+    namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, name);
+    if (namedHashPtr == NULL) {
+	Tcl_AppendResult(interp, "named font \"", name,
+		"\" doesn't exist", (char *) NULL);
+	return TCL_ERROR;
+    }
+    nfPtr = (NamedFont *) Tcl_GetHashValue(namedHashPtr);
+    if (nfPtr->refCount != 0) {
+	nfPtr->deletePending = 1;
+    } else {
+	Tcl_DeleteHashEntry(namedHashPtr);
+	ckfree((char *) nfPtr);
+    }
+    return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
  * Tk_GetFont --
  *
  *	Given a string description of a font, map the description to a
diff --git a/generic/tkFont.h b/generic/tkFont.h
index 9ea3488..448423d 100644
--- a/generic/tkFont.h
+++ b/generic/tkFont.h
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkFont.h,v 1.9 2006/12/01 20:14:23 kennykb Exp $
+ * RCS: @(#) $Id: tkFont.h,v 1.10 2007/05/04 21:29:22 patthoyts Exp $
  */
 
 #ifndef _TKFONT
@@ -203,6 +203,10 @@ MODULE_SCOPE int	TkFontGetPixels(Tk_Window tkwin, int size);
 MODULE_SCOPE int	TkFontGetPoints(Tk_Window tkwin, int size);
 MODULE_SCOPE char **	TkFontGetGlobalClass(void);
 MODULE_SCOPE char **	TkFontGetSymbolClass(void);
+MODULE_SCOPE int	TkCreateNamedFont(Tcl_Interp *interp, Tk_Window tkwin,
+			    CONST char *name, TkFontAttributes *faPtr);
+MODULE_SCOPE int	TkDeleteNamedFont(Tcl_Interp *interp,
+			    Tk_Window tkwin, CONST char *name);
 MODULE_SCOPE int	TkFontGetFirstTextLayout(Tk_TextLayout layout,
 			    Tk_Font *font, char *dst);
 
diff --git a/library/demos/widget b/library/demos/widget
index ec964f9..c4e9fd6 100644
--- a/library/demos/widget
+++ b/library/demos/widget
@@ -11,7 +11,7 @@ exec wish "$0" "$@"
 # ".tcl" files is this directory, which are sourced by this script
 # as needed.
 #
-# RCS: @(#) $Id: widget,v 1.28 2006/09/11 14:41:04 das Exp $
+# RCS: @(#) $Id: widget,v 1.29 2007/05/04 21:29:22 patthoyts Exp $
 
 package require Tcl	8.5
 package require Tk	8.5
@@ -33,12 +33,26 @@ if {[tk windowingsystem] eq "x11"} {
 }
 
 if {[lsearch -exact [font names] defaultFont] == -1} {
-    font create mainFont   -family Helvetica -size 12
-    font create fixedFont  -family Courier   -size 10
-    font create boldFont   -family Helvetica -size 12 -weight bold
-    font create titleFont  -family Helvetica -size 18 -weight bold
-    font create statusFont -family Helvetica -size 10
-    font create varsFont   -family Helvetica -size 14
+    # TIP #145 defines some standard named fonts
+    if {[lsearch -exact [font names] TkDefaultFont] != -1} {
+        # FIX ME: the following tecnique of cloning the font to copy it works
+        #         fine but means that if the system font is changed by
+        #         Tk cannot update the copied font. font alias might be
+        #         useful here -- or fix the app to use TkDefaultFont etc.
+        font create mainFont   {*}[font configure TkDefaultFont]
+        font create fixedFont  {*}[font configure TkFixedFont]
+        font create boldFont   {*}[font configure TkDefaultFont] -weight bold
+        font create titleFont  {*}[font configure TkDefaultFont] -weight bold
+        font create statusFont {*}[font configure TkDefaultFont]
+        font create varsFont   {*}[font configure TkDefaultFont]
+    } else {        
+        font create mainFont   -family Helvetica -size 12
+        font create fixedFont  -family Courier   -size 10
+        font create boldFont   -family Helvetica -size 12 -weight bold
+        font create titleFont  -family Helvetica -size 18 -weight bold
+        font create statusFont -family Helvetica -size 10
+        font create varsFont   -family Helvetica -size 14
+    }
 }
 
 set widgetDemo 1
diff --git a/library/ttk/fonts.tcl b/library/ttk/fonts.tcl
index db15ad1..8cb6c33 100644
--- a/library/ttk/fonts.tcl
+++ b/library/ttk/fonts.tcl
@@ -1,5 +1,5 @@
 #
-# $Id: fonts.tcl,v 1.3 2006/11/28 21:25:27 jenglish Exp $
+# $Id: fonts.tcl,v 1.4 2007/05/04 21:29:22 patthoyts Exp $
 #
 # Font specifications.
 #
@@ -75,7 +75,8 @@
 
 namespace eval ttk {
 
-catch {font create TkDefaultFont}
+
+set tip145 [catch {font create TkDefaultFont}]
 catch {font create TkTextFont}
 catch {font create TkHeadingFont}
 catch {font create TkCaptionFont}
@@ -100,12 +101,14 @@ switch -- [tk windowingsystem] {
         }
 	set F(size) 8
 
-	font configure TkDefaultFont -family $F(family) -size $F(size)
-	font configure TkTextFont    -family $F(family) -size $F(size)
-	font configure TkHeadingFont -family $F(family) -size $F(size)
-	font configure TkCaptionFont -family $F(family) -size $F(size) \
-					-weight bold
-	font configure TkTooltipFont -family $F(family) -size $F(size)
+        if {!$tip145} {
+            font configure TkDefaultFont -family $F(family) -size $F(size)
+            font configure TkTextFont    -family $F(family) -size $F(size)
+            font configure TkHeadingFont -family $F(family) -size $F(size)
+            font configure TkCaptionFont -family $F(family) -size $F(size) \
+                -weight bold
+            font configure TkTooltipFont -family $F(family) -size $F(size)
+        }
     }
     aqua {
 	set F(family) "Lucida Grande"
diff --git a/win/tkWinDefault.h b/win/tkWinDefault.h
index e0946c6..f2267fa 100644
--- a/win/tkWinDefault.h
+++ b/win/tkWinDefault.h
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkWinDefault.h,v 1.21 2006/09/06 22:39:28 hobbs Exp $
+ * RCS: @(#) $Id: tkWinDefault.h,v 1.22 2007/05/04 21:29:22 patthoyts Exp $
  */
 
 #ifndef _TKWINDEFAULT
@@ -28,7 +28,7 @@
 #define BLACK		"Black"
 #define WHITE		"White"
 
-#define CTL_FONT	"{MS Sans Serif} 8"
+#define CTL_FONT	"TkDefaultFont" /*"{MS Sans Serif} 8"*/
 #define NORMAL_BG	"SystemButtonFace"
 #define NORMAL_FG	"SystemButtonText"
 #define ACTIVE_BG	NORMAL_BG
@@ -285,7 +285,7 @@
 #define DEF_MENU_CURSOR			"arrow"
 #define DEF_MENU_DISABLED_FG_COLOR	DISABLED
 #define DEF_MENU_DISABLED_FG_MONO	""
-#define DEF_MENU_FONT			CTL_FONT
+#define DEF_MENU_FONT			"TkMenuFont" /* CTL_FONT */
 #define DEF_MENU_FG			MENU_FG
 #define DEF_MENU_POST_COMMAND		""
 #define DEF_MENU_RELIEF			"flat"
diff --git a/win/tkWinFont.c b/win/tkWinFont.c
index 2f5671b..5021955 100644
--- a/win/tkWinFont.c
+++ b/win/tkWinFont.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: tkWinFont.c,v 1.31 2007/01/18 23:56:44 nijtmans Exp $
+ * RCS: @(#) $Id: tkWinFont.c,v 1.32 2007/05/04 21:29:22 patthoyts Exp $
  */
 
 #include "tkWinInt.h"
@@ -159,8 +159,10 @@ typedef struct CanUse {
 
 static const TkStateMap systemMap[] = {
     {ANSI_FIXED_FONT,	    "ansifixed"},
+    {ANSI_FIXED_FONT,	    "fixed"},
     {ANSI_VAR_FONT,	    "ansi"},
     {DEVICE_DEFAULT_FONT,   "device"},
+    {DEFAULT_GUI_FONT,	    "defaultgui"},
     {OEM_FIXED_FONT,	    "oemfixed"},
     {SYSTEM_FIXED_FONT,	    "systemfixed"},
     {SYSTEM_FONT,	    "system"},
@@ -208,6 +210,11 @@ static void		InitFont(Tk_Window tkwin, HFONT hFont,
 			    int overstrike, WinFont *tkFontPtr);
 static void		InitSubFont(HDC hdc, HFONT hFont, int base,
 			    SubFont *subFontPtr);
+static int		CreateNamedSystemLogFont(Tcl_Interp *interp,
+			    Tk_Window tkwin, CONST char* name,
+			    LOGFONT* logFontPtr);
+static int		CreateNamedSystemFont(Tcl_Interp *interp,
+			    Tk_Window tkwin, CONST char* name, HFONT hFont);
 static int		LoadFontRanges(HDC hdc, HFONT hFont,
 			    USHORT **startCount, USHORT **endCount,
 			    int *symbolPtr);
@@ -260,6 +267,8 @@ TkpFontPkgInit(
 
 	systemEncoding = TkWinGetUnicodeEncoding();
     }
+
+    TkWinSetupSystemFonts(mainPtr);
 }
 
 /*
@@ -311,6 +320,138 @@ TkpGetNativeFont(
 
 /*
  *---------------------------------------------------------------------------
+ * CreateNamedSystemFont --
+ *
+ *	This function registers a Windows logical font description with the Tk
+ *	named font mechanism.
+ *
+ * Side effects
+ *
+ *	A new named font is added to the Tk font registry.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+CreateNamedSystemLogFont(
+    Tcl_Interp *interp,
+    Tk_Window tkwin,
+    CONST char* name,
+    LOGFONT* logFontPtr)
+{
+    HFONT hFont;
+    int r;
+    
+    hFont = CreateFontIndirect(logFontPtr);
+    r = CreateNamedSystemFont(interp, tkwin, name, hFont);
+    DeleteObject((HGDIOBJ)hFont);
+    return r;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ * CreateNamedSystemFont --
+ *
+ *	This function registers a Windows font with the Tk
+ *	named font mechanism.
+ *
+ * Side effects
+ *
+ *	A new named font is added to the Tk font registry.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+CreateNamedSystemFont(
+    Tcl_Interp *interp,
+    Tk_Window tkwin,
+    CONST char* name,
+    HFONT hFont)
+{
+    TkFontAttributes *faPtr;
+    WinFont *fontPtr;
+    int r;
+    
+    TkDeleteNamedFont(interp, tkwin, name);
+    
+    fontPtr = (WinFont *) ckalloc(sizeof(WinFont));
+    InitFont(tkwin, hFont, 0, fontPtr);
+    faPtr = (TkFontAttributes*)ckalloc(sizeof(TkFontAttributes));
+    memcpy(faPtr, &fontPtr->font.fa, sizeof(TkFontAttributes));
+    r = TkCreateNamedFont(interp, tkwin, name, faPtr);
+    TkpDeleteFont((TkFont *)fontPtr);
+    ckfree((char *) fontPtr);
+    return r;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ * TkWinSystemFonts --
+ *
+ *	Create some platform specific named fonts that to give access to the
+ *	system fonts. These are all defined for the Windows desktop parameters.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TkWinSetupSystemFonts(TkMainInfo *mainPtr)
+{
+    Tcl_Interp *interp;
+    Tk_Window tkwin;
+    const TkStateMap *mapPtr;
+    NONCLIENTMETRICS ncMetrics;
+    ICONMETRICS iconMetrics;
+    HFONT hFont;
+    
+    interp = (Tcl_Interp *) mainPtr->interp;
+    tkwin = (Tk_Window) mainPtr->winPtr;
+    
+    /* force this for now */
+    if (((TkWindow *) tkwin)->mainPtr == NULL)
+        ((TkWindow *) tkwin)->mainPtr = mainPtr;
+    
+    ncMetrics.cbSize = sizeof(ncMetrics);
+    SystemParametersInfo(SPI_GETNONCLIENTMETRICS, sizeof(ncMetrics),
+	    &ncMetrics, 0);
+    
+    CreateNamedSystemLogFont(interp, tkwin, "TkDefaultFont",
+	    &ncMetrics.lfMessageFont);
+    CreateNamedSystemLogFont(interp, tkwin, "TkHeadingFont",
+	    &ncMetrics.lfMessageFont);
+    CreateNamedSystemLogFont(interp, tkwin, "TkTextFont",
+	    &ncMetrics.lfMessageFont);
+    CreateNamedSystemLogFont(interp, tkwin, "TkMenuFont",
+	    &ncMetrics.lfMenuFont);
+    CreateNamedSystemLogFont(interp, tkwin, "TkTooltipFont",
+	    &ncMetrics.lfStatusFont);
+    CreateNamedSystemLogFont(interp, tkwin, "TkCaptionFont",
+	    &ncMetrics.lfCaptionFont);
+    CreateNamedSystemLogFont(interp, tkwin, "TkSmallCaptionFont",
+	    &ncMetrics.lfSmCaptionFont);
+
+    iconMetrics.cbSize = sizeof(iconMetrics);
+    SystemParametersInfo(SPI_GETICONMETRICS, sizeof(iconMetrics),
+	    &iconMetrics, 0);
+    CreateNamedSystemLogFont(interp, tkwin, "TkIconFont",
+	    &iconMetrics.lfFont);
+    
+    hFont = (HFONT)GetStockObject(ANSI_FIXED_FONT);
+    CreateNamedSystemFont(interp, tkwin, "TkFixedFont", hFont);
+    
+    /* 
+     * Setup the remaining standard Tk font names as named fonts.
+     */
+
+    for (mapPtr = systemMap; mapPtr->strKey != NULL; mapPtr++) {
+        hFont = (HFONT)GetStockObject(mapPtr->numKey);
+        CreateNamedSystemFont(interp, tkwin, mapPtr->strKey, hFont);
+    }
+}
+
+/*
+ *---------------------------------------------------------------------------
  *
  * TkpGetFontFromAttributes --
  *
diff --git a/win/tkWinInt.h b/win/tkWinInt.h
index 1f54c65..c6ba4f7 100644
--- a/win/tkWinInt.h
+++ b/win/tkWinInt.h
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkWinInt.h,v 1.27 2007/01/05 00:00:52 nijtmans Exp $
+ * RCS: @(#) $Id: tkWinInt.h,v 1.28 2007/05/04 21:29:23 patthoyts Exp $
  */
 
 #ifndef _TKWININT
@@ -226,6 +226,7 @@ EXTERN TkWinProcs *tkWinProcs;
 
 extern Tcl_Encoding	TkWinGetKeyInputEncoding(void);
 extern Tcl_Encoding	TkWinGetUnicodeEncoding(void);
+extern void		TkWinSetupSystemFonts(TkMainInfo *mainPtr);
 
 /*
  * Values returned by TkWinGetPlatformTheme.
diff --git a/win/tkWinWm.c b/win/tkWinWm.c
index 2a0df7d..e089985 100644
--- a/win/tkWinWm.c
+++ b/win/tkWinWm.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkWinWm.c,v 1.115 2007/02/23 14:15:34 dkf Exp $
+ * RCS: @(#) $Id: tkWinWm.c,v 1.116 2007/05/04 21:29:23 patthoyts Exp $
  */
 
 #include "tkWinInt.h"
@@ -7820,6 +7820,15 @@ WmProc(
 	result = InstallColormaps(hwnd, WM_QUERYNEWPALETTE, TRUE);
 	goto done;
 
+    case WM_SETTINGCHANGE:
+	if (wParam == SPI_SETNONCLIENTMETRICS) {
+	    winPtr = GetTopLevel(hwnd);
+	    TkWinSetupSystemFonts(winPtr->mainPtr);
+	    result = 0;
+	    goto done;
+	}
+	break;
+
     case WM_WINDOWPOSCHANGED:
 	ConfigureTopLevel((WINDOWPOS *) lParam);
 	result = 0;