Updated implementation of TIP #145

Index: generic/tkFont.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkFont.c,v
retrieving revision 1.30
diff -u -r1.30 tkFont.c
--- generic/tkFont.c	10 Dec 2006 05:26:42 -0000	1.30
+++ generic/tkFont.c	21 Dec 2006 22:51:14 -0000
@@ -326,8 +326,6 @@
 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);
@@ -658,7 +656,7 @@
 		&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);
@@ -667,8 +665,6 @@
     case FONT_DELETE: {
 	int i;
 	char *string;
-	NamedFont *nfPtr;
-	Tcl_HashEntry *namedHashPtr;
 
 	/*
 	 * Delete the named font. If there are still widgets using this font,
@@ -681,19 +677,7 @@
 	}
 	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;
     }
@@ -917,7 +901,7 @@
 /*
  *---------------------------------------------------------------------------
  *
- * CreateNamedFont --
+ * TkCreateNamedFont --
  *
  *	Create the specified named font with the given attributes in the named
  *	font table associated with the interp.
@@ -938,8 +922,8 @@
  *---------------------------------------------------------------------------
  */
 
-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. */
@@ -987,6 +971,45 @@
 /*
  *---------------------------------------------------------------------------
  *
+ * 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
Index: generic/tkFont.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkFont.h,v
retrieving revision 1.9
diff -u -r1.9 tkFont.h
--- generic/tkFont.h	1 Dec 2006 20:14:23 -0000	1.9
+++ generic/tkFont.h	21 Dec 2006 22:51:14 -0000
@@ -203,6 +203,10 @@
 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);
 
Index: library/demos/widget
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/demos/widget,v
retrieving revision 1.28
diff -u -r1.28 widget
--- library/demos/widget	11 Sep 2006 14:41:04 -0000	1.28
+++ library/demos/widget	22 Dec 2006 09:55:56 -0000
@@ -33,12 +33,26 @@
 }
 
 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
Index: library/ttk/fonts.tcl
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/ttk/fonts.tcl,v
retrieving revision 1.3
diff -u -r1.3 fonts.tcl
--- library/ttk/fonts.tcl	28 Nov 2006 21:25:27 -0000	1.3
+++ library/ttk/fonts.tcl	22 Dec 2006 09:56:16 -0000
@@ -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 @@
         }
 	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"
Index: win/tkWinDefault.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinDefault.h,v
retrieving revision 1.21
diff -u -r1.21 tkWinDefault.h
--- win/tkWinDefault.h	6 Sep 2006 22:39:28 -0000	1.21
+++ win/tkWinDefault.h	22 Dec 2006 02:10:28 -0000
@@ -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"
Index: win/tkWinFont.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinFont.c,v
retrieving revision 1.28
diff -u -r1.28 tkWinFont.c
--- win/tkWinFont.c	1 Dec 2006 20:14:24 -0000	1.28
+++ win/tkWinFont.c	22 Dec 2006 01:59:46 -0000
@@ -159,8 +159,10 @@
 
 static 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 @@
 			    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 @@
 
 	systemEncoding = TkWinGetUnicodeEncoding();
     }
+
+    TkWinSetupSystemFonts(mainPtr);
 }
 
 /*
@@ -311,6 +320,138 @@
 
 /*
  *---------------------------------------------------------------------------
+ * 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;
+    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 --
  *
Index: win/tkWinInt.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinInt.h,v
retrieving revision 1.26
diff -u -r1.26 tkWinInt.h
--- win/tkWinInt.h	2 Dec 2005 13:42:29 -0000	1.26
+++ win/tkWinInt.h	21 Dec 2006 22:51:14 -0000
@@ -226,6 +226,7 @@
 
 extern Tcl_Encoding	TkWinGetKeyInputEncoding(void);
 extern Tcl_Encoding	TkWinGetUnicodeEncoding(void);
+extern void		TkWinSetupSystemFonts(TkMainInfo *mainPtr);
 
 /*
  * Values returned by TkWinGetPlatformTheme.
Index: win/tkWinWm.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinWm.c,v
retrieving revision 1.110
diff -u -r1.110 tkWinWm.c
--- win/tkWinWm.c	1 Dec 2006 19:48:00 -0000	1.110
+++ win/tkWinWm.c	21 Dec 2006 22:51:14 -0000
@@ -7809,6 +7809,15 @@
 	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;
