TIP 300 IMPLEMENTATION

10 files changed, 320 insertions, 25 deletions

diff --git a/ChangeLog b/ChangeLog
index 16f7c1d..6cd7250 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2006-12-01  Kevin Kenny  <kennykb@acm.org>
+
+	TIP #300 IMPLEMENTATION
+
+	* doc/font.n:			Added a [font actual $font $char]
+	* generic/tkFont.c:		variant that introspects the font
+	* generic/tkFont.h:		that is chosen to render a given
+	* macosx/tkMacOSXFont.c:	character in a given nominal font.
+	* tests/font.test:		Added documentation and test cases
+	* unix/tkUnixFont.c:		for the new command syntax.
+	* unix/tkUnixRFont.c:
+	* win/tkWinFont.c:
+	
 2006-12-01  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* doc/wm.n, tests/winWm.test:
diff --git a/doc/font.n b/doc/font.n
index 8e844d0..32d8ef1 100644
--- a/doc/font.n
+++ b/doc/font.n
@@ -4,7 +4,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: font.n,v 1.8 2005/04/06 21:11:54 dkf Exp $
+'\" RCS: @(#) $Id: font.n,v 1.9 2006/12/01 20:14:23 kennykb Exp $
 '\" 
 .so man.macros
 .TH font n 8.0 Tk "Tk Built-In Commands"
@@ -22,7 +22,7 @@ fonts, such as defining named fonts and inspecting the actual attributes of
 a font.  The command has several different forms, determined by the
 first argument.  The following forms are currently supported:
 .TP
-\fBfont actual \fIfont\fR ?\fB\-displayof \fIwindow\fR? ?\fIoption\fR?  
+\fBfont actual \fIfont\fR ?\fB\-displayof \fIwindow\fR? ?\fIoption\fR? ?\fB--\fR? ?\fIchar\fR?
 .
 Returns information about the actual attributes that are obtained when
 \fIfont\fR is used on \fIwindow\fR's display; the actual attributes obtained
@@ -32,7 +32,12 @@ limitations, such as the availability of font families and pointsizes.
 \fIwindow\fR argument is omitted, it defaults to the main window.  If
 \fIoption\fR is specified, returns the value of that attribute; if it is
 omitted, the return value is a list of all the attributes and their values.
-See FONT OPTIONS below for a list of the possible attributes.
+See FONT OPTIONS below for a list of the possible attributes.  If the
+\fIchar\fR argument is supplied, it must be a single character. The font
+attributes returned will be those of the specific font used to render
+that character, which will be different from the base font if the base
+font does not contain the given character.  If \fIchar\fR may be a hyphen, it
+should be preceded by \fB--\fR to distinguish it from a misspelt \fIoption\fR.
 .TP 
 \fBfont configure \fIfontname\fR ?\fIoption\fR? ?\fIvalue option value ...\fR?  
 .
diff --git a/generic/tkFont.c b/generic/tkFont.c
index 3d64409..15ec180 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.28 2006/03/22 00:21:16 das Exp $
+ * RCS: @(#) $Id: tkFont.c,v 1.29 2006/12/01 20:14:23 kennykb Exp $
  */
 
 #include "tkPort.h"
@@ -503,31 +503,88 @@ Tk_FontObjCmd(
     switch ((enum options) index) {
     case FONT_ACTUAL: {
 	int skip, result;
+	int n;
+	const char* s;
 	Tk_Font tkfont;
-	Tcl_Obj *objPtr;
+	Tcl_Obj *optPtr;
+	Tcl_Obj *charPtr;
+	Tcl_Obj *resultPtr;
+	Tcl_UniChar uniChar;
 	CONST TkFontAttributes *faPtr;
+	TkFontAttributes fa;
 
+	/* 
+	 * Params 0 and 1 are 'font actual'.  Param 2 is the
+	 * font name. 3-4 may be '-displayof $window'
+	 */
 	skip = TkGetDisplayOf(interp, objc - 3, objv + 3, &tkwin);
 	if (skip < 0) {
 	    return TCL_ERROR;
 	}
-	if ((objc < 3) || (objc - skip > 4)) {
+
+	/* Next parameter may be an option */
+	n = skip + 3;
+	optPtr = NULL;
+	charPtr = NULL;
+	if (n < objc) {
+	    s = Tcl_GetString(objv[n]);
+	    if (s[0] == '-' && s[1] != '-') {
+		optPtr = objv[n];
+		++n;
+	    } else {
+		optPtr = NULL;
+	    }
+	}
+
+	/* Next parameter may be '--' to mark end of options */
+	if (n < objc) {
+	    if (!strcmp(Tcl_GetString(objv[n]), "--")) {
+		++n;
+	    }
+	}
+
+	/* Next parameter is the character to get font information for */
+	if (n < objc) {
+	    charPtr = objv[n];
+	    ++n;
+	}
+
+	/* If there were fewer than 3 args, or args remain, that's an error */
+	if (objc < 3 || n < objc) {
 	    Tcl_WrongNumArgs(interp, 2, objv,
-		    "font ?-displayof window? ?option?");
+		    "font ?-displayof window? ?option? ?--? ?char?");
 	    return TCL_ERROR;
 	}
+
+	/* The 'charPtr' arg must be a single Unicode */
+	if (charPtr != NULL) {
+	    if (Tcl_GetCharLength(charPtr) != 1) {
+		resultPtr =  Tcl_NewStringObj("expected a single character "
+					      "but got \"", -1);
+		Tcl_AppendLimitedToObj(resultPtr, Tcl_GetString(charPtr),
+				       -1, 40, "...");
+		Tcl_AppendToObj(resultPtr, "\"", -1);
+		Tcl_SetObjResult(interp, resultPtr);
+		return TCL_ERROR;
+	    }
+	    uniChar = Tcl_GetUniChar(charPtr, 0);
+	}
+
+	/* Find the font */
 	tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]);
 	if (tkfont == NULL) {
 	    return TCL_ERROR;
 	}
-	objc -= skip;
-	objv += skip;
+	
+	/* Determine the font attributes */
+	if (charPtr == NULL) {
 	faPtr = GetFontAttributes(tkfont);
-	objPtr = NULL;
-	if (objc > 3) {
-	    objPtr = objv[3];
+	} else {
+	    TkpGetFontAttrsForChar(tkwin, tkfont, uniChar, &fa);
+	    faPtr = &fa;
 	}
-	result = GetAttributeInfoObj(interp, faPtr, objPtr);
+	result = GetAttributeInfoObj(interp, faPtr, optPtr);
+
 	Tk_FreeFont(tkfont);
 	return result;
     }
diff --git a/generic/tkFont.h b/generic/tkFont.h
index cc362fb..9ea3488 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.8 2006/03/22 00:21:16 das Exp $
+ * RCS: @(#) $Id: tkFont.h,v 1.9 2006/12/01 20:14:23 kennykb Exp $
  */
 
 #ifndef _TKFONT
@@ -27,7 +27,7 @@
  * attributes gotten when the font was instantiated.
  */
 
-typedef struct TkFontAttributes {
+struct TkFontAttributes {
     Tk_Uid family;		/* Font family, or NULL to represent plaform-
 				 * specific default system font. */
     int size;			/* Pointsize of font, 0 for default size, or
@@ -36,7 +36,7 @@ typedef struct TkFontAttributes {
     int slant;			/* Slant flag; see below for def'n. */
     int underline;		/* Non-zero for underline font. */
     int overstrike;		/* Non-zero for overstrike font. */
-} TkFontAttributes;
+};
 
 /*
  * Possible values for the "weight" field in a TkFontAttributes structure.
diff --git a/generic/tkInt.h b/generic/tkInt.h
index 7a5335f..2e1679e 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.74 2006/10/31 01:42:25 hobbs Exp $
+ * RCS: $Id: tkInt.h,v 1.75 2006/12/01 20:14:23 kennykb Exp $
  */
 
 #ifndef _TKINT
@@ -71,6 +71,7 @@
  */
 
 typedef struct TkColormap TkColormap;
+typedef struct TkFontAttributes TkFontAttributes;
 typedef struct TkGrabEvent TkGrabEvent;
 typedef struct TkpCursor_ *TkpCursor;
 typedef struct TkRegion_ *TkRegion;
@@ -1180,6 +1181,9 @@ MODULE_SCOPE void	TkUnderlineCharsInContext(Display *display,
 			    Drawable drawable, GC gc, Tk_Font tkfont,
 			    const char *string, int numBytes, int x, int y,
 			    int firstByte, int lastByte);
+MODULE_SCOPE void	TkpGetFontAttrsForChar(Tk_Window tkwin, Tk_Font tkfont,
+					       Tcl_UniChar c, 
+					       struct TkFontAttributes *faPtr);
 
 /*
  * Unsupported commands.
diff --git a/macosx/tkMacOSXFont.c b/macosx/tkMacOSXFont.c
index 280e649..25689c5 100644
--- a/macosx/tkMacOSXFont.c
+++ b/macosx/tkMacOSXFont.c
@@ -35,7 +35,7 @@
  *   that such fonts can not be used for controls, because controls
  *   definitely require a family id (this assertion needs testing).
  *
- * RCS: @(#) $Id: tkMacOSXFont.c,v 1.19 2006/07/20 06:25:19 das Exp $
+ * RCS: @(#) $Id: tkMacOSXFont.c,v 1.20 2006/12/01 20:14:23 kennykb Exp $
  */
 
 #include "tkMacOSXInt.h"
@@ -465,6 +465,38 @@ TkpGetSubFonts(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * TkpGetFontAttrsForChar --
+ *
+ *	Retrieve the font attributes of the actual font used to render
+ *	a given character.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The font attributes are stored in *faPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TkpGetFontAttrsForChar(
+    Tk_Window tkwin,		/* Window on the font's display */
+    Tk_Font tkfont,		/* Font to query */
+    Tcl_UniChar c,		/* Character of interest */
+    TkFontAttributes* faPtr)	/* Output: Font attributes */
+{
+    /* 
+     * Once again, we don't know what ATSU is doing for us. Simply
+     * return the attributes of the base font.
+     */
+    TkMacOSXFont* fontPtr = (TkMacOSXFont*) tkfont;
+    *faPtr = fontPtr->font.fa;
+}
+
+/*
  *---------------------------------------------------------------------------
  *
  *  Tk_MeasureChars --
diff --git a/tests/font.test b/tests/font.test
index e573bc9..8dbaf0f 100644
--- a/tests/font.test
+++ b/tests/font.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: font.test,v 1.13 2006/03/22 00:21:18 das Exp $
+# RCS: @(#) $Id: font.test,v 1.14 2006/12/01 20:14:23 kennykb Exp $
 
 package require tcltest 2.1
 eval tcltest::configure $argv
@@ -115,11 +115,11 @@ test font-4.1 {font command: actual: arguments} {
 test font-4.2 {font command: actual: arguments} {
     # (objc < 3) 
     list [catch {font actual} msg] $msg
-} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}}
+} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}}
 test font-4.3 {font command: actual: arguments} {
     # (objc - skip > 4) when skip == 0
     list [catch {font actual xyz abc def} msg] $msg
-} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}}
+} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}}
 test font-4.4 {font command: actual: displayof specified, so skip to next} {
     catch {font actual xyz -displayof . -size}
 } {0}
@@ -129,7 +129,7 @@ test font-4.5 {font command: actual: displayof specified, so skip to next} {
 test font-4.6 {font command: actual: arguments} {
     # (objc - skip > 4) when skip == 2
     list [catch {font actual xyz -displayof . abc def} msg] $msg
-} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}}
+} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}}
 test font-4.7 {font command: actual: arguments} {noExceed} {
     # (tkfont == NULL)
     list [catch {font actual "\{xyz"} msg] $msg
@@ -1334,6 +1334,36 @@ test font-45.4 {TkFontGetAliasList: match} {unix noExceed} {
     font actual {{times new roman} 10} -family
 } [font actual {times 10} -family]
 
+test font-46.1 {font actual, with character, no option, no --} \
+    -body {
+	font actual {times 10} a
+    } \
+    -match glob \
+    -result "-family [font actual {times 10} -family] -size *\
+             -slant roman -underline 0 -overstrike 0"
+
+test font-46.2 {font actual, with character introduced by --} \
+    -body {
+	font actual {times 10} -- -
+    } \
+    -match glob \
+    -result "-family [font actual {times 10} -family] -size *\
+             -slant roman -underline 0 -overstrike 0"
+
+test font-46.3 {font actual, with character and option} {
+    font actual {times 10} -family a
+} [font actual {times 10} -family]
+
+test font-46.4 {font actual, with character, option and --} {
+    font actual {times 10} -family -- -
+} [font actual {times 10} -family]
+
+test font-46.5 {font actual, too many chars} {
+    list [catch {
+	font actual {times 10} 123456789012345678901234567890123456789012345678901
+    } result] $result
+} {1 {expected a single character but got "1234567890123456789012345678901234567..."}}
+
 setup
 
 destroy .b
diff --git a/unix/tkUnixFont.c b/unix/tkUnixFont.c
index 9174f8e..0ab8fb5 100644
--- a/unix/tkUnixFont.c
+++ b/unix/tkUnixFont.c
@@ -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: tkUnixFont.c,v 1.29 2006/10/05 21:27:43 hobbs Exp $
+ * RCS: @(#) $Id: tkUnixFont.c,v 1.30 2006/12/01 20:14:23 kennykb Exp $
  */
 
 #include "tkUnixInt.h"
@@ -930,6 +930,44 @@ TkpGetSubFonts(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * TkpGetFontAttrsForChar --
+ *
+ *	Retrieve the font attributes of the actual font used to render
+ *	a given character.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The font attributes are stored in *faPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TkpGetFontAttrsForChar(
+    Tk_Window tkwin,		/* Window on the font's display */
+    Tk_Font tkfont,		/* Font to query */
+    Tcl_UniChar c,		/* Character of interest */
+    TkFontAttributes* faPtr)	/* Output: Font attributes */
+{
+    FontAttributes atts;
+    UnixFont *fontPtr = (UnixFont *) tkfont;
+				/* Structure describing the logical font */
+    SubFont *lastSubFontPtr = &fontPtr->subFontArray[0];
+				/* Pointer to subfont array in case
+				 * FindSubFontForChar needs to fix up the
+				 * memory allocation */
+    SubFont *thisSubFontPtr = FindSubFontForChar(fontPtr, c, &lastSubFontPtr);
+				/* Pointer to the subfont to use for the
+				 * given character */
+    GetFontAttributes(Tk_Display(tkwin), thisSubFontPtr->fontStructPtr, &atts);
+    *faPtr = atts.fa;
+}
+
+/*
  *---------------------------------------------------------------------------
  *
  * Tk_MeasureChars --
diff --git a/unix/tkUnixRFont.c b/unix/tkUnixRFont.c
index 407bcf6..285ac8e 100644
--- a/unix/tkUnixRFont.c
+++ b/unix/tkUnixRFont.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkUnixRFont.c,v 1.13 2006/03/23 22:08:51 rmax Exp $
+ * RCS: @(#) $Id: tkUnixRFont.c,v 1.14 2006/12/01 20:14:23 kennykb Exp $
  */
 
 #include "tkUnixInt.h"
@@ -469,6 +469,66 @@ TkpGetSubFonts(
     Tcl_SetObjResult(interp, resultPtr);
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkpGetFontAttrsForChar --
+ *
+ *	Retrieve the font attributes of the actual font used to render
+ *	a given character.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The font attributes are stored in *faPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TkpGetFontAttrsForChar(
+    Tk_Window tkwin,		/* Window on the font's display */
+    Tk_Font tkfont,		/* Font to query */
+    Tcl_UniChar c,		/* Character of interest */
+    TkFontAttributes* faPtr)	/* Output: Font attributes */
+{
+    UnixFtFont *fontPtr = (UnixFtFont*) tkfont;
+				/* Structure describing the logical font */
+    FcChar32 ucs4 = (FcChar32) c;
+				/* UCS-4 character to map */
+    XftFont *xftFontPtr = GetFont(fontPtr, ucs4);
+				/* Actual font used to render the character */
+    const char* family;		/* Font family name */
+    double size;		/* Font size */
+    int weight;			/* Font weight */
+    int slant;			/* Font slant */
+    
+    if (XftPatternGetString(xftFontPtr->pattern, XFT_FAMILY, 0,
+			    &family) != XftResultMatch) {
+	family = "Unknown";
+    }
+    if (XftPatternGetDouble(xftFontPtr->pattern, XFT_SIZE, 0,
+			    &size) != XftResultMatch) {
+	size = 12.0;
+    }
+    if (XftPatternGetInteger(xftFontPtr->pattern, XFT_WEIGHT, 0,
+			     &weight) != XftResultMatch) {
+	weight = XFT_WEIGHT_MEDIUM;
+    }
+    if (XftPatternGetInteger(xftFontPtr->pattern, XFT_SLANT, 0,
+			     &slant) != XftResultMatch) {
+	slant = XFT_SLANT_ROMAN;
+    }
+    faPtr->family = Tk_GetUid(family);
+    faPtr->size = (int) size;
+    faPtr->weight = (weight > XFT_WEIGHT_MEDIUM) ? TK_FW_BOLD : TK_FW_NORMAL;
+    faPtr->slant = (slant > XFT_SLANT_ROMAN) ? TK_FS_ITALIC : TK_FS_ROMAN;
+    faPtr->underline = fontPtr->font.fa.underline;
+    faPtr->overstrike = fontPtr->font.fa.overstrike;
+
+}
+
 int
 Tk_MeasureChars(
     Tk_Font tkfont,		/* Font in which characters will be drawn. */
diff --git a/win/tkWinFont.c b/win/tkWinFont.c
index bddaed9..564471d 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.27 2006/03/22 00:21:20 das Exp $
+ * RCS: @(#) $Id: tkWinFont.c,v 1.28 2006/12/01 20:14:24 kennykb Exp $
  */
 
 #include "tkWinInt.h"
@@ -561,6 +561,62 @@ TkpGetSubFonts(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * TkpGetFontAttrsForChar --
+ *
+ *	Retrieve the font attributes of the actual font used to render
+ *	a given character.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The font attributes are stored in *faPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TkpGetFontAttrsForChar(
+    Tk_Window tkwin,		/* Window on the font's display */
+    Tk_Font tkfont,		/* Font to query */
+    Tcl_UniChar c,		/* Character of interest */
+    TkFontAttributes* faPtr)	/* Output: Font attributes */
+{
+    WinFont *fontPtr = (WinFont *) tkfont;
+				/* Structure describing the logical font */
+    HDC hdc = GetDC(fontPtr->hwnd);
+				/* GDI device context */
+    SubFont *lastSubFontPtr = &fontPtr->subFontArray[0];
+				/* Pointer to subfont array in case
+				 * FindSubFontForChar needs to fix up
+				 * the memory allocation */
+    SubFont *thisSubFontPtr = FindSubFontForChar(fontPtr, c,
+						 &lastSubFontPtr);
+				/* Pointer to the subfont to use for
+				 * the given character */
+    FontFamily *familyPtr = thisSubFontPtr->familyPtr;
+    HFONT oldfont;		/* Saved font from the device context */
+    TEXTMETRIC tm;		/* Font metrics of the selected subfont */
+
+  
+    /* Get the font attributes */
+
+    oldfont = SelectObject(hdc, thisSubFontPtr->hFont);
+    GetTextMetrics(hdc, &tm);
+    SelectObject(hdc, oldfont);
+    ReleaseDC(fontPtr->hwnd, hdc);
+    faPtr->family = familyPtr->faceName;
+    faPtr->size = TkFontGetPoints(tkwin,
+				  tm.tmInternalLeading - tm.tmHeight);
+    faPtr->weight = (tm.tmWeight > FW_MEDIUM) ? TK_FW_BOLD : TK_FW_NORMAL;
+    faPtr->slant = tm.tmItalic ? TK_FS_ITALIC : TK_FS_ROMAN;
+    faPtr->underline = (tm.tmUnderlined != 0);
+    faPtr->overstrike = fontPtr->font.fa.overstrike;
+}
+
+/*
  *---------------------------------------------------------------------------
  *
  *  Tk_MeasureChars --