From e6279912ba852370baf9d434e5985b355430daad Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 14 Aug 2020 15:05:29 +0000
Subject: New function Tk_FontGetDescription()

---
 doc/GetFont.3        |  8 +++++++-
 generic/tk.decls     |  3 +++
 generic/tkDecls.h    |  5 +++++
 generic/tkFont.c     | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tkStubInit.c |  1 +
 5 files changed, 67 insertions(+), 1 deletion(-)

diff --git a/doc/GetFont.3 b/doc/GetFont.3
index 0504916..9497556 100644
--- a/doc/GetFont.3
+++ b/doc/GetFont.3
@@ -9,7 +9,7 @@
 .so man.macros
 .BS
 .SH NAME
-Tk_AllocFontFromObj, Tk_GetFont, Tk_GetFontFromObj, Tk_NameOfFont, Tk_FreeFontFromObj, Tk_FreeFont \- maintain database of fonts
+Tk_AllocFontFromObj, Tk_GetFont, Tk_GetFontFromObj, Tk_NameOfFont, Tk_FontGetDescription, Tk_FreeFontFromObj, Tk_FreeFont \- maintain database of fonts
 .SH SYNOPSIS
 .nf
 \fB#include <tk.h>\fR
@@ -23,6 +23,9 @@ Tk_Font
 Tk_Font
 \fBTk_GetFontFromObj(\fItkwin, objPtr\fB)\fR
 .sp
+Tcl_Obj *
+\fBTk_FontGetDescription(\fItkfont\fB)\fR
+.sp
 const char *
 \fBTk_NameOfFont(\fItkfont\fB)\fR
 .sp
@@ -88,6 +91,9 @@ windows or for different purposes), then a single Tk_Font will be
 shared for all uses.  The underlying resources will be freed automatically
 when no-one is using the font anymore.
 .PP
+The procedure \fBTk_FontGetDescription\fR returns information about the font
+description as a Tcl list. One possible result is "{{DejaVu Sans} -16 bold underline}".
+.PP
 The procedure \fBTk_NameOfFont\fR is roughly the inverse of
 \fBTk_GetFont\fR.  Given a \fItkfont\fR that was created by
 \fBTk_GetFont\fR (or \fBTk_AllocFontFromObj\fR), the return value is
diff --git a/generic/tk.decls b/generic/tk.decls
index 0184f86..c885e9b 100644
--- a/generic/tk.decls
+++ b/generic/tk.decls
@@ -1087,6 +1087,9 @@ declare 278 {
     void Tk_SendVirtualEvent(Tk_Window tkwin, const char *eventName,
 	    Tcl_Obj *detail)
 }
+declare 279 {
+    Tcl_Obj *Tk_FontGetDescription(Tk_Font tkfont)
+}
 
 # Define the platform specific public Tk interface.  These functions are
 # only available on the designated platform.
diff --git a/generic/tkDecls.h b/generic/tkDecls.h
index e55854c..bb2fdd4 100644
--- a/generic/tkDecls.h
+++ b/generic/tkDecls.h
@@ -891,6 +891,8 @@ EXTERN Tcl_Obj *	Tk_NewWindowObj(Tk_Window tkwin);
 /* 278 */
 EXTERN void		Tk_SendVirtualEvent(Tk_Window tkwin,
 				const char *eventName, Tcl_Obj *detail);
+/* 279 */
+EXTERN Tcl_Obj *	Tk_FontGetDescription(Tk_Font tkfont);
 
 typedef struct {
     const struct TkPlatStubs *tkPlatStubs;
@@ -1182,6 +1184,7 @@ typedef struct TkStubs {
     int (*tk_GetDoublePixelsFromObj) (Tcl_Interp *interp, Tk_Window tkwin, Tcl_Obj *objPtr, double *doublePtr); /* 276 */
     Tcl_Obj * (*tk_NewWindowObj) (Tk_Window tkwin); /* 277 */
     void (*tk_SendVirtualEvent) (Tk_Window tkwin, const char *eventName, Tcl_Obj *detail); /* 278 */
+    Tcl_Obj * (*tk_FontGetDescription) (Tk_Font tkfont); /* 279 */
 } TkStubs;
 
 extern const TkStubs *tkStubsPtr;
@@ -1752,6 +1755,8 @@ extern const TkStubs *tkStubsPtr;
 	(tkStubsPtr->tk_NewWindowObj) /* 277 */
 #define Tk_SendVirtualEvent \
 	(tkStubsPtr->tk_SendVirtualEvent) /* 278 */
+#define Tk_FontGetDescription \
+	(tkStubsPtr->tk_FontGetDescription) /* 279 */
 
 #endif /* defined(USE_TK_STUBS) */
 
diff --git a/generic/tkFont.c b/generic/tkFont.c
index d2aa6d2..6659025 100644
--- a/generic/tkFont.c
+++ b/generic/tkFont.c
@@ -3577,6 +3577,57 @@ GetAttributeInfoObj(
 /*
  *---------------------------------------------------------------------------
  *
+ * Tk_FontGetDescription --
+ *
+ *	Return information about the font description as a Tcl list. One
+ *	possible result is "{{DejaVu Sans} -16 bold underline}".
+ *
+ * Results:
+ *	The list of descriptions.
+ *
+ * Side effects:
+ *	None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tk_FontGetDescription(
+    Tk_Font tkfont)		/* Font whose description is desired. */
+{
+    const TkFontAttributes *faPtr = GetFontAttributes(tkfont);
+    Tcl_Obj *resultPtr = Tcl_NewObj();
+    const char *str;
+
+    str = faPtr->family;
+    Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(str, str ? -1 : 0));
+    if (faPtr->size >= 0.0) {
+    	Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewWideIntObj((int)(faPtr->size + 0.5)));
+    } else {
+    	Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewWideIntObj(-(int)(-faPtr->size + 0.5)));
+    }
+    if (faPtr->weight != TK_FW_NORMAL) {
+	str = TkFindStateString(weightMap, faPtr->weight);
+	Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(str, -1));
+    }
+    if (faPtr->slant != TK_FS_ROMAN) {
+	str = TkFindStateString(slantMap, faPtr->slant);
+	Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(str, -1));
+    }
+    if (faPtr->underline) {
+	str = TkFindStateString(underlineMap, faPtr->underline);
+	Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(str, -1));
+    }
+    if (faPtr->overstrike) {
+	str = TkFindStateString(overstrikeMap, faPtr->overstrike);
+	Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(str, -1));
+    }
+    return resultPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
  * ParseFontNameObj --
  *
  *	Converts a object into a set of font attributes that can be used to
diff --git a/generic/tkStubInit.c b/generic/tkStubInit.c
index 8c27797..eb2dd47 100644
--- a/generic/tkStubInit.c
+++ b/generic/tkStubInit.c
@@ -1335,6 +1335,7 @@ const TkStubs tkStubs = {
     Tk_GetDoublePixelsFromObj, /* 276 */
     Tk_NewWindowObj, /* 277 */
     Tk_SendVirtualEvent, /* 278 */
+    Tk_FontGetDescription, /* 279 */
 };
 
 /* !END!: Do not edit above this line. */
-- 
cgit v0.12