/*

* tkFont.c --

*

* This file maintains a database of fonts for the Tk toolkit. It also

* provides several utility functions for measuring and displaying text.

*

* Copyright © 1990-1994 The Regents of the University of California.

* Copyright © 1994-1998 Sun Microsystems, Inc.

*

* See the file "license.terms" for information on usage and redistribution of

* this file, and for a DISCLAIMER OF ALL WARRANTIES.

*/

#include "tkInt.h"

#include "tkFont.h"

#if defined(MAC_OSX_TK)

#include "tkMacOSXInt.h" /* Defines TK_DRAW_IN_CONTEXT */

#endif

#ifdef _WIN32

#include "tkWinInt.h"

#endif

/*

* The following structure is used to keep track of all the fonts that exist

* in the current application. It must be stored in the TkMainInfo for the

* application.

*/

typedef struct TkFontInfo {

Tcl_HashTable fontCache; /* Map a string to an existing Tk_Font. Keys

* are string font names, values are TkFont

* pointers. */

Tcl_HashTable namedTable; /* Map a name to a set of attributes for a

* font, used when constructing a Tk_Font from

* a named font description. Keys are strings,

* values are NamedFont pointers. */

TkMainInfo *mainPtr; /* Application that owns this structure. */

int updatePending; /* Non-zero when a World Changed event has

* already been queued to handle a change to a

* named font. */

} TkFontInfo;

/*

* The following data structure is used to keep track of the font attributes

* for each named font that has been defined. The named font is only deleted

* when the last reference to it goes away.

*/

typedef struct NamedFont {

size_t refCount; /* Number of users of named font. */

int deletePending; /* Non-zero if font should be deleted when

* last reference goes away. */

TkFontAttributes fa; /* Desired attributes for named font. */

} NamedFont;

/*

* The following two structures are used to keep track of string measurement

* information when using the text layout facilities.

*

* A LayoutChunk represents a contiguous range of text that can be measured

* and displayed by low-level text calls. In general, chunks will be delimited

* by newlines and tabs. Low-level, platform-specific things like kerning and

* non-integer character widths may occur between the characters in a single

* chunk, but not between characters in different chunks.

*

* A TextLayout is a collection of LayoutChunks. It can be displayed with

* respect to any origin. It is the implementation of the Tk_TextLayout opaque

* token.

*/

typedef struct LayoutChunk {

const char *start; /* Pointer to simple string to be displayed.

* This is a pointer into the TkTextLayout's

* string. */

Tcl_Size numBytes; /* The number of bytes in this chunk. */

Tcl_Size numChars; /* The number of characters in this chunk. */

Tcl_Size numDisplayChars; /* The number of characters to display when

* this chunk is displayed. Can be less than

* numChars if extra space characters were

* absorbed by the end of the chunk. This will

* be < 0 if this is a chunk that is holding a

* tab or newline. */

int x, y; /* The origin of the first character in this

* chunk with respect to the upper-left hand

* corner of the TextLayout. */

int totalWidth; /* Width in pixels of this chunk. Used when

* hit testing the invisible spaces at the end

* of a chunk. */

int displayWidth; /* Width in pixels of the displayable

* characters in this chunk. Can be less than

* width if extra space characters were

* absorbed by the end of the chunk. */

} LayoutChunk;

typedef struct TextLayout {

Tk_Font tkfont; /* The font used when laying out the text. */

const char *string; /* The string that was layed out. */

int width; /* The maximum width of all lines in the text

* layout. */

Tcl_Size numChunks; /* Number of chunks actually used in following

* array. */

LayoutChunk chunks[TKFLEXARRAY];/* Array of chunks. The actual size will be

* maxChunks. THIS FIELD MUST BE THE LAST IN

* THE STRUCTURE. */

} TextLayout;

/*

* The following structures are used as two-way maps between the values for

* the fields in the TkFontAttributes structure and the strings used in Tcl,

* when parsing both option-value format and style-list format font name

* strings.

*/

static const TkStateMap weightMap[] = {

{TK_FW_NORMAL, "normal"},

{TK_FW_BOLD, "bold"},

{TK_FW_UNKNOWN, NULL}

};

static const TkStateMap slantMap[] = {

{TK_FS_ROMAN, "roman"},

{TK_FS_ITALIC, "italic"},

{TK_FS_UNKNOWN, NULL}

};

static const TkStateMap underlineMap[] = {

{1, "underline"},

{0, NULL}

};

static const TkStateMap overstrikeMap[] = {

{1, "overstrike"},

{0, NULL}

};

/*

* The following structures are used when parsing XLFD's into a set of

* TkFontAttributes.

*/

static const TkStateMap xlfdWeightMap[] = {

{TK_FW_NORMAL, "normal"},

{TK_FW_NORMAL, "medium"},

{TK_FW_NORMAL, "book"},

{TK_FW_NORMAL, "light"},

{TK_FW_BOLD, "bold"},

{TK_FW_BOLD, "demi"},

{TK_FW_BOLD, "demibold"},

{TK_FW_NORMAL, NULL} /* Assume anything else is "normal". */

};

static const TkStateMap xlfdSlantMap[] = {

{TK_FS_ROMAN, "r"},

{TK_FS_ITALIC, "i"},

{TK_FS_OBLIQUE, "o"},

{TK_FS_ROMAN, NULL} /* Assume anything else is "roman". */

};

static const TkStateMap xlfdSetwidthMap[] = {

{TK_SW_NORMAL, "normal"},

{TK_SW_CONDENSE, "narrow"},

{TK_SW_CONDENSE, "semicondensed"},

{TK_SW_CONDENSE, "condensed"},

{TK_SW_UNKNOWN, NULL}

};

/*

* The following structure and defines specify the valid builtin options when

* configuring a set of font attributes.

*/

static const char *const fontOpt[] = {

"-family",

"-size",

"-weight",

"-slant",

"-underline",

"-overstrike",

NULL

};

#define FONT_FAMILY 0

#define FONT_SIZE 1

#define FONT_WEIGHT 2

#define FONT_SLANT 3

#define FONT_UNDERLINE 4

#define FONT_OVERSTRIKE 5

#define FONT_NUMFIELDS 6

/*

* Hardcoded font aliases. These are used to describe (mostly) identical fonts

* whose names differ from platform to platform. If the user-supplied font

* name matches any of the names in one of the alias lists, the other names in

* the alias list are also automatically tried.

*/

static const char *const timesAliases[] = {

"Times", /* Unix. */

"Times New Roman", /* Windows. */

"New York", /* Mac. */

NULL

};

static const char *const helveticaAliases[] = {

"Helvetica", /* Unix. */

"Arial", /* Windows. */

"Geneva", /* Mac. */

NULL

};

static const char *const courierAliases[] = {

"Courier", /* Unix and Mac. */

"Courier New", /* Windows. */

NULL

};

static const char *const minchoAliases[] = {

"mincho", /* Unix. */

"\357\274\255\357\274\263 \346\230\216\346\234\235",

/* Windows (MS mincho). */

"\346\234\254\346\230\216\346\234\235\342\210\222\357\274\255",

/* Mac (honmincho-M). */

NULL

};

static const char *const gothicAliases[] = {

"gothic", /* Unix. */

"\357\274\255\357\274\263 \343\202\264\343\202\267\343\203\203\343\202\257",

/* Windows (MS goshikku). */

"\344\270\270\343\202\264\343\202\267\343\203\203\343\202\257\342\210\222\357\274\255",

/* Mac (goshikku-M). */

NULL

};

static const char *const dingbatsAliases[] = {

"dingbats", "zapfdingbats", "itc zapfdingbats",

/* Unix. */

/* Windows. */

"zapf dingbats", /* Mac. */

NULL

};

static const char *const *const fontAliases[] = {

timesAliases,

helveticaAliases,

courierAliases,

minchoAliases,

gothicAliases,

dingbatsAliases,

NULL

};

/*

* Hardcoded font classes. If the character cannot be found in the base font,

* the classes are examined in order to see if some other similar font should

* be examined also.

*/

static const char *const systemClass[] = {

"fixed", /* Unix. */

/* Windows. */

"chicago", "osaka", "sistemny",

/* Mac. */

NULL

};

static const char *const serifClass[] = {

"times", "palatino", "mincho",

/* All platforms. */

"song ti", /* Unix. */

"ms serif", "simplified arabic",

/* Windows. */

"latinski", /* Mac. */

NULL

};

static const char *const sansClass[] = {

"helvetica", "gothic", /* All platforms. */

/* Unix. */

"ms sans serif", "traditional arabic",

/* Windows. */

"bastion", /* Mac. */

NULL

};

static const char *const monoClass[] = {

"courier", "gothic", /* All platforms. */

"fangsong ti", /* Unix. */

"simplified arabic fixed", /* Windows. */

"monaco", "pryamoy", /* Mac. */

NULL

};

static const char *const symbolClass[] = {

"symbol", "dingbats", "wingdings", NULL

};

static const char *const *const fontFallbacks[] = {

systemClass,

serifClass,

sansClass,

monoClass,

symbolClass,

NULL

};

/*

* Global fallbacks. If the character could not be found in the preferred

* fallback list, this list is examined. If the character still cannot be

* found, all font families in the system are examined.

*/

static const char *const globalFontClass[] = {

"symbol", /* All platforms. */

/* Unix. */

"lucida sans unicode", /* Windows. */

"bitstream cyberbit", /* Windows popular CJK font */

"chicago", /* Mac. */

NULL

};

#define GetFontAttributes(tkfont) \

((const TkFontAttributes *) &((TkFont *) (tkfont))->fa)

#define GetFontMetrics(tkfont) \

((const TkFontMetrics *) &((TkFont *) (tkfont))->fm)

static int ConfigAttributesObj(Tcl_Interp *interp,

Tk_Window tkwin, Tcl_Size objc, Tcl_Obj *const objv[],

TkFontAttributes *faPtr);

static void DupFontObjProc(Tcl_Obj *srcObjPtr, Tcl_Obj *dupObjPtr);

static int FieldSpecified(const char *field);

static void FreeFontObj(Tcl_Obj *objPtr);

static void FreeFontObjProc(Tcl_Obj *objPtr);

static int GetAttributeInfoObj(Tcl_Interp *interp,

const TkFontAttributes *faPtr, Tcl_Obj *objPtr);

static LayoutChunk * NewChunk(TextLayout **layoutPtrPtr, Tcl_Size *maxPtr,

const char *start, Tcl_Size numChars, int curX,

int newX, int y);

static int ParseFontNameObj(Tcl_Interp *interp, Tk_Window tkwin,

Tcl_Obj *objPtr, TkFontAttributes *faPtr);

static void RecomputeWidgets(TkWindow *winPtr);

static int SetFontFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);

static void TheWorldHasChanged(void *clientData);

static void UpdateDependentFonts(TkFontInfo *fiPtr,

Tk_Window tkwin, Tcl_HashEntry *namedHashPtr);

/*

* The following structure defines the implementation of the "font" Tcl

* object, used for drawing. The internalRep.twoPtrValue.ptr1 field of each

* font object points to the TkFont structure for the font, or NULL.

*/

const TkObjType tkFontObjType = {

{"font", /* name */

FreeFontObjProc, /* freeIntRepProc */

DupFontObjProc, /* dupIntRepProc */

NULL, /* updateStringProc */

NULL, /* setFromAnyProc */

TCL_OBJTYPE_V0},

0

};



/*

*---------------------------------------------------------------------------

*

* TkFontPkgInit --

*

* This function is called when an application is created. It initializes

* all the structures that are used by the font package on a per

* application basis.

*

* Results:

* Stores a token in the mainPtr to hold information needed by this

* package on a per application basis.

*

* Side effects:

* Memory allocated.

*

*---------------------------------------------------------------------------

*/

void

TkFontPkgInit(

TkMainInfo *mainPtr) /* The application being created. */

{

TkFontInfo *fiPtr = (TkFontInfo *)ckalloc(sizeof(TkFontInfo));

Tcl_InitHashTable(&fiPtr->fontCache, TCL_STRING_KEYS);

Tcl_InitHashTable(&fiPtr->namedTable, TCL_STRING_KEYS);

fiPtr->mainPtr = mainPtr;

fiPtr->updatePending = 0;

mainPtr->fontInfoPtr = fiPtr;

TkpFontPkgInit(mainPtr);

}



/*

*---------------------------------------------------------------------------

*

* TkFontPkgFree --

*

* This function is called when an application is deleted. It deletes all

* the structures that were used by the font package for this

* application.

*

* Results:

* None.

*

* Side effects:

* Memory freed.

*

*---------------------------------------------------------------------------

*/

void

TkFontPkgFree(

TkMainInfo *mainPtr) /* The application being deleted. */

{

TkFontInfo *fiPtr = mainPtr->fontInfoPtr;

Tcl_HashEntry *hPtr, *searchPtr;

Tcl_HashSearch search;

#ifdef PURIFY

int fontsLeft = 0;

#endif

for (searchPtr = Tcl_FirstHashEntry(&fiPtr->fontCache, &search);

searchPtr != NULL;

searchPtr = Tcl_NextHashEntry(&search)) {

#ifdef PURIFY

fontsLeft++;

#endif

#ifdef DEBUG_FONTS

fprintf(stderr, "Font %s still in cache.\n",

(char *) Tcl_GetHashKey(&fiPtr->fontCache, searchPtr));

#endif

}

#ifdef PURIFY

if (fontsLeft) {

Tcl_Panic("TkFontPkgFree: all fonts should have been freed already");

}

#endif

Tcl_DeleteHashTable(&fiPtr->fontCache);

hPtr = Tcl_FirstHashEntry(&fiPtr->namedTable, &search);

while (hPtr != NULL) {

ckfree(Tcl_GetHashValue(hPtr));

hPtr = Tcl_NextHashEntry(&search);

}

Tcl_DeleteHashTable(&fiPtr->namedTable);

if (fiPtr->updatePending) {

Tcl_CancelIdleCall(TheWorldHasChanged, fiPtr);

}

ckfree(fiPtr);

}



/*

*---------------------------------------------------------------------------

*

* Tk_FontObjCmd --

*

* This function is implemented to process the "font" Tcl command. See

* the user documentation for details on what it does.

*

* Results:

* A standard Tcl result.

*

* Side effects:

* See the user documentation.

*

*----------------------------------------------------------------------

*/

int

Tk_FontObjCmd(

void *clientData, /* Main window associated with interpreter. */

Tcl_Interp *interp, /* Current interpreter. */

int objc, /* Number of arguments. */

Tcl_Obj *const objv[]) /* Argument objects. */

{

int index;

Tk_Window tkwin = (Tk_Window)clientData;

TkFontInfo *fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr;

static const char *const optionStrings[] = {

"actual", "configure", "create", "delete",

"families", "measure", "metrics", "names",

NULL

};

enum options {

FONT_ACTUAL, FONT_CONFIGURE, FONT_CREATE, FONT_DELETE,

FONT_FAMILIES, FONT_MEASURE, FONT_METRICS, FONT_NAMES

};

if (objc < 2) {

Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?");

return TCL_ERROR;

}

if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,

&index) != TCL_OK) {

return TCL_ERROR;

}

switch ((enum options) index) {

case FONT_ACTUAL: {

int result;

Tcl_Size skip, n;

const char *s;

Tk_Font tkfont;

Tcl_Obj *optPtr, *charPtr, *resultPtr;

int uniChar = 0;

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;

}

/*

* Next parameter may be an option.

*/

n = 3 + skip;

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? ?--? ?char?");

return TCL_ERROR;

}

/*

* The 'charPtr' arg must be a single Unicode.

*/

if (charPtr != NULL) {

const char *string = Tcl_GetString(charPtr);

Tcl_Size len = Tcl_UtfToUniChar(string, &uniChar);

if (len != charPtr->length) {

resultPtr = Tcl_NewStringObj(

"expected a single character but got \"", TCL_INDEX_NONE);

Tcl_AppendLimitedToObj(resultPtr, string,

TCL_INDEX_NONE, 40, "...");

Tcl_AppendToObj(resultPtr, "\"", TCL_INDEX_NONE);

Tcl_SetObjResult(interp, resultPtr);

Tcl_SetErrorCode(interp, "TK", "VALUE", "FONT_SAMPLE", (char *)NULL);

return TCL_ERROR;

}

}

/*

* Find the font.

*/

tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]);

if (tkfont == NULL) {

return TCL_ERROR;

}

/*

* Determine the font attributes.

*/

if (charPtr == NULL) {

faPtr = GetFontAttributes(tkfont);

} else {

TkpGetFontAttrsForChar(tkwin, tkfont, uniChar, &fa);

faPtr = &fa;

}

result = GetAttributeInfoObj(interp, faPtr, optPtr);

Tk_FreeFont(tkfont);

return result;

}

case FONT_CONFIGURE: {

int result;

const char *string;

Tcl_Obj *objPtr;

NamedFont *nfPtr;

Tcl_HashEntry *namedHashPtr;

if (objc < 3) {

Tcl_WrongNumArgs(interp, 2, objv, "fontname ?-option value ...?");

return TCL_ERROR;

}

string = Tcl_GetString(objv[2]);

namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, string);

nfPtr = NULL;

if (namedHashPtr != NULL) {

nfPtr = (NamedFont *)Tcl_GetHashValue(namedHashPtr);

}

if ((namedHashPtr == NULL) || nfPtr->deletePending) {

Tcl_SetObjResult(interp, Tcl_ObjPrintf(

"named font \"%s\" does not exist", string));

Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", string, (char *)NULL);

return TCL_ERROR;

}

if (objc == 3) {

objPtr = NULL;

} else if (objc == 4) {

objPtr = objv[3];

} else {

result = ConfigAttributesObj(interp, tkwin, objc - 3, objv + 3,

&nfPtr->fa);

UpdateDependentFonts(fiPtr, tkwin, namedHashPtr);

return result;

}

return GetAttributeInfoObj(interp, &nfPtr->fa, objPtr);

}

case FONT_CREATE: {

int skip = 3, i;

const char *name;

char buf[16 + TCL_INTEGER_SPACE];

TkFontAttributes fa;

Tcl_HashEntry *namedHashPtr;

if (objc < 3) {

name = NULL;

} else {

name = Tcl_GetString(objv[2]);

if (name[0] == '-') {

name = NULL;

}

}

if (name == NULL) {

/*

* No font name specified. Generate one of the form "fontX".

*/

for (i = 1; ; i++) {

snprintf(buf, sizeof(buf), "font%d", i);

namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, buf);

if (namedHashPtr == NULL) {

break;

}

}

name = buf;

skip = 2;

}

TkInitFontAttributes(&fa);

if (ConfigAttributesObj(interp, tkwin, objc - skip, objv + skip,

&fa) != TCL_OK) {

return TCL_ERROR;

}

if (TkCreateNamedFont(interp, tkwin, name, &fa) != TCL_OK) {

return TCL_ERROR;

}

Tcl_SetObjResult(interp, Tcl_NewStringObj(name, TCL_INDEX_NONE));

break;

}

case FONT_DELETE: {

Tcl_Size i;

int result = TCL_OK;

const char *string;

/*

* Delete the named font. If there are still widgets using this font,

* then it isn't deleted right away.

*/

if (objc < 3) {

Tcl_WrongNumArgs(interp, 2, objv, "fontname ?fontname ...?");

return TCL_ERROR;

}

for (i = 2; (i < objc) && (result == TCL_OK); i++) {

string = Tcl_GetString(objv[i]);

result = TkDeleteNamedFont(interp, tkwin, string);

}

return result;

}

case FONT_FAMILIES: {

Tcl_Size skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin);

if (skip < 0) {

return TCL_ERROR;

}

if (objc != 2 + skip) {

Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window?");

return TCL_ERROR;

}

TkpGetFontFamilies(interp, tkwin);

break;

}

case FONT_MEASURE: {

const char *string;

Tk_Font tkfont;

Tcl_Size length = 0;

Tcl_Size skip = 0;

if (objc > 4) {

skip = TkGetDisplayOf(interp, objc - 3, objv + 3, &tkwin);

if (skip < 0) {

return TCL_ERROR;

}

}

if (objc != 4 + skip) {

Tcl_WrongNumArgs(interp, 2, objv,

"font ?-displayof window? text");

return TCL_ERROR;

}

tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]);

if (tkfont == NULL) {

return TCL_ERROR;

}

string = Tcl_GetStringFromObj(objv[3 + skip], &length);

Tcl_SetObjResult(interp, Tcl_NewWideIntObj(

Tk_TextWidth(tkfont, string, length)));

Tk_FreeFont(tkfont);

break;

}

case FONT_METRICS: {

Tk_Font tkfont;

Tcl_Size skip;

int i;

const TkFontMetrics *fmPtr;

static const char *const switches[] = {

"-ascent", "-descent", "-fixed", "-linespace", NULL

};

skip = TkGetDisplayOf(interp, objc - 3, objv + 3, &tkwin);

if (skip < 0) {

return TCL_ERROR;

}

if ((objc < 3) || (objc > 4 + skip)) {

Tcl_WrongNumArgs(interp, 2, objv,

"font ?-displayof window? ?-option?");

return TCL_ERROR;

}

tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]);

if (tkfont == NULL) {

return TCL_ERROR;

}

objc -= skip;

objv += skip;

fmPtr = GetFontMetrics(tkfont);

if (objc == 3) {

Tcl_SetObjResult(interp, Tcl_ObjPrintf(

"-ascent %d -descent %d -linespace %d -fixed %d",

fmPtr->ascent, fmPtr->descent,

fmPtr->ascent + fmPtr->descent, fmPtr->fixed));

} else {

if (Tcl_GetIndexFromObj(interp, objv[3], switches, "metric", 0,

&index) != TCL_OK) {

Tk_FreeFont(tkfont);

return TCL_ERROR;

}

i = 0; /* Needed only to prevent compiler warning. */

switch (index) {

case 0: i = fmPtr->ascent; break;

case 1: i = fmPtr->descent; break;

case 2: i = fmPtr->fixed; break;

case 3: i = fmPtr->ascent + fmPtr->descent; break;

}

Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));

}

Tk_FreeFont(tkfont);

break;

}

case FONT_NAMES: {

Tcl_HashSearch search;

Tcl_HashEntry *namedHashPtr;

Tcl_Obj *resultPtr;

if (objc != 2) {

Tcl_WrongNumArgs(interp, 1, objv, "names");

return TCL_ERROR;

}

resultPtr = Tcl_NewObj();

namedHashPtr = Tcl_FirstHashEntry(&fiPtr->namedTable, &search);

while (namedHashPtr != NULL) {

NamedFont *nfPtr = (NamedFont *)Tcl_GetHashValue(namedHashPtr);

if (!nfPtr->deletePending) {

char *string = (char *)Tcl_GetHashKey(&fiPtr->namedTable,

namedHashPtr);

Tcl_ListObjAppendElement(NULL, resultPtr,

Tcl_NewStringObj(string, TCL_INDEX_NONE));

}

namedHashPtr = Tcl_NextHashEntry(&search);

}

Tcl_SetObjResult(interp, resultPtr);

break;

}

}

return TCL_OK;

}



/*

*---------------------------------------------------------------------------

*

* UpdateDependentFonts, TheWorldHasChanged, RecomputeWidgets --

*

* Called when the attributes of a named font changes. Updates all the

* instantiated fonts that depend on that named font and then uses the

* brute force approach and prepares every widget to recompute its

* geometry.

*

* Results:

* None.

*

* Side effects:

* Things get queued for redisplay.

*

*---------------------------------------------------------------------------

*/

static void

UpdateDependentFonts(

TkFontInfo *fiPtr, /* Info about application's fonts. */

Tk_Window tkwin, /* A window in the application. */

Tcl_HashEntry *namedHashPtr)/* The named font that is changing. */

{

Tcl_HashEntry *cacheHashPtr;

Tcl_HashSearch search;

TkFont *fontPtr;

NamedFont *nfPtr = (NamedFont *)Tcl_GetHashValue(namedHashPtr);

if (nfPtr->refCount == 0) {

/*

* Well nobody's using this named font, so don't have to tell any

* widgets to recompute themselves.

*/

return;

}

cacheHashPtr = Tcl_FirstHashEntry(&fiPtr->fontCache, &search);

while (cacheHashPtr != NULL) {

for (fontPtr = (TkFont *)Tcl_GetHashValue(cacheHashPtr);

fontPtr != NULL; fontPtr = fontPtr->nextPtr) {

if (fontPtr->namedHashPtr == namedHashPtr) {

TkpGetFontFromAttributes(fontPtr, tkwin, &nfPtr->fa);

if (!fiPtr->updatePending) {

fiPtr->updatePending = 1;

Tcl_DoWhenIdle(TheWorldHasChanged, fiPtr);

}

}

}

cacheHashPtr = Tcl_NextHashEntry(&search);

}

}

static void

TheWorldHasChanged(

void *clientData) /* Info about application's fonts. */

{

TkFontInfo *fiPtr = (TkFontInfo *)clientData;

fiPtr->updatePending = 0;

RecomputeWidgets(fiPtr->mainPtr->winPtr);

}

static void

RecomputeWidgets(

TkWindow *winPtr) /* Window to which command is sent. */

{

Tk_ClassWorldChangedProc *proc =

Tk_GetClassProc(winPtr->classProcsPtr, worldChangedProc);

TkWindow *tkwinPtr;

if (proc != NULL) {

proc(winPtr->instanceData);

}

/*

* Notify all the descendants of this window that the world has changed.

*

* This could be done recursively or iteratively. The recursive version is

* easier to implement and understand, and typically, windows with a -font

* option will be leaf nodes in the widget hierarchy (buttons, labels,

* etc.), so the recursion depth will be shallow.

*

* However, the additional overhead of the recursive calls may become a

* performance problem if typical usage alters such that -font'ed widgets

* appear high in the hierarchy, causing deep recursion. This could happen

* with text widgets, or more likely with the labelframe

* widget. With these widgets it is possible, even likely, that a

* -font'ed widget (text or labelframe) will not be a leaf node, but

* will instead have many descendants. If this is ever found to cause a

* performance problem, it may be worth investigating an iterative version

* of the code below.

*/

for (tkwinPtr=winPtr->childList ; tkwinPtr!=NULL ; tkwinPtr=tkwinPtr->nextPtr) {

RecomputeWidgets(tkwinPtr);

}

/*

* Broadcast font change virtually for mega-widget layout managers.

* Do this after the font change has been propagated to core widgets.

*/

Tk_SendVirtualEvent((Tk_Window)winPtr, "TkWorldChanged",

Tcl_NewStringObj("FontChanged",-1));

}



/*

*---------------------------------------------------------------------------

*

* TkCreateNamedFont --

*

* Create the specified named font with the given attributes in the named

* font table associated with the interp.

*

* Results:

* Returns TCL_OK if the font was successfully created, or TCL_ERROR if

* the named font already existed. If TCL_ERROR is returned, an error

* message is left in the interp's result.

*

* Side effects:

* Assume there used to exist a named font by the specified name, and

* that the named font had been deleted, but there were still some

* widgets using the named font at the time it was deleted. If a new

* named font is created with the same name, all those widgets that were

* using the old named font will be redisplayed using the new named

* font's attributes.

*

*---------------------------------------------------------------------------

*/

int

TkCreateNamedFont(

Tcl_Interp *interp, /* Interp for error return (can be NULL). */

Tk_Window tkwin, /* A window associated with interp. */

const char *name, /* Name for the new named font. */

TkFontAttributes *faPtr) /* Attributes for the new named font. */

{

TkFontInfo *fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr;

Tcl_HashEntry *namedHashPtr;

int isNew;

NamedFont *nfPtr;

namedHashPtr = Tcl_CreateHashEntry(&fiPtr->namedTable, name, &isNew);

if (!isNew) {

nfPtr = (NamedFont *)Tcl_GetHashValue(namedHashPtr);

if (!nfPtr->deletePending) {

if (interp) {

Tcl_SetObjResult(interp, Tcl_ObjPrintf(

"named font \"%s\" already exists", name));

Tcl_SetErrorCode(interp, "TK", "FONT", "EXISTS", (char *)NULL);

}

return TCL_ERROR;

}

/*

* Recreating a named font with the same name as a previous named

* font. Some widgets were still using that named font, so they need

* to get redisplayed.

*/

nfPtr->fa = *faPtr;

nfPtr->deletePending = 0;

UpdateDependentFonts(fiPtr, tkwin, namedHashPtr);

return TCL_OK;

}

nfPtr = (NamedFont *)ckalloc(sizeof(NamedFont));