Tk Source Code

2013-07-02  Jan Nijtmans  <[email protected]>

	* unix/tcl.m4:  Bug [32afa6e256]: dirent64 check is incorrect in tcl.m4
	* unix/configure: (thanks to Brian Griffin)

2012-06-28  Jan Nijtmans  <[email protected]>

#define __NO_OLD_CONFIG
#endif

#include "tkInt.h"
#include "tkFont.h"

/*
 * The following definition is an AssocData key used to keep track of all of
 * the option tables that have been created for an interpreter.
 */






#define OPTION_HASH_KEY "TkOptionTable"

/*
 * The following two structures are used along with Tk_OptionSpec structures
 * to manage configuration options. Tk_OptionSpec is static templates that are
 * compiled into the code of a widget or other object manager. However, to
 * look up options efficiently we need to supplement the static information
 * with additional dynamic information, and this dynamic information may be

				 * used to delete the entry. */
    struct OptionTable *nextPtr;/* If templatePtr was part of a chain of
				 * templates, this points to the table
				 * corresponding to the next template in the
				 * chain. */
    int numOptions;		/* The number of items in the options array
				 * below. */
    int refCount2; /* Reference counter for controlling the freeing
                    * of the memory occupied by this OptionTable */
    Option options[1];		/* Information about the individual options in
				 * the table. This must be the last field in
				 * the structure: the actual size of the array
				 * will be numOptions, not 1. */
} OptionTable;

/*
 * Forward declarations for functions defined later in this file:
 */

static int		DoObjConfig(Tcl_Interp *interp, char *recordPtr,
			    Option *optionPtr, Tcl_Obj *valuePtr,
			    Tk_Window tkwin, Tk_SavedOption *savePtr);
static void		DestroyOptionHashTable(ClientData clientData,
			    Tcl_Interp *interp);
static void		FreeResources(Option *optionPtr, Tcl_Obj *objPtr,
			    char *internalPtr, Tk_Window tkwin);
static Tcl_Obj *	GetConfigList(char *recordPtr,
			    Option *optionPtr, Tk_Window tkwin);
static Tcl_Obj *	GetObjectForOption(char *recordPtr,
			    Option *optionPtr, Tk_Window tkwin);
static Option *		GetOption(const char *name, OptionTable *tablePtr);
static Option *		GetOptionFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, OptionTable *tablePtr);
static int		ObjectIsEmpty(Tcl_Obj *objPtr);
static void		FreeOptionInternalRep(Tcl_Obj *objPtr);


/*
 * The structure below defines an object type that is used to cache the result
 * of looking up an option name. If an object has this type, then its
 * internalPtr1 field points to the OptionTable in which it was looked up, and
 * the internalPtr2 field points to the entry that matched.
 */

static const Tcl_ObjType optionObjType = {
    "option",			/* name */
    FreeOptionInternalRep,	/* freeIntRepProc */
    NULL,			/* dupIntRepProc */
    NULL,			/* updateStringProc */
    NULL			/* setFromAnyProc */
};

/*
 *--------------------------------------------------------------
 *

Tk_CreateOptionTable(
    Tcl_Interp *interp,		/* Interpreter associated with the application
				 * in which this table will be used. */
    const Tk_OptionSpec *templatePtr)
				/* Static information about the configuration
				 * options. */
{
    Tcl_HashTable *hashTablePtr;
    Tcl_HashEntry *hashEntryPtr;
    int newEntry;
    OptionTable *tablePtr;
    const Tk_OptionSpec *specPtr, *specPtr2;
    Option *optionPtr;
    int numOptions, i;



    /*
     * We use an AssocData value in the interpreter to keep a hash table of
     * all the option tables we've created for this application. This is used
     * for two purposes. First, it allows us to share the tables (e.g. in
     * several chains) and second, we use the deletion callback for the
     * AssocData to delete all the option tables when the interpreter is
     * deleted. The code below finds the hash table or creates a new one if it
     * doesn't already exist.
     */

    hashTablePtr = Tcl_GetAssocData(interp, OPTION_HASH_KEY, NULL);
    if (hashTablePtr == NULL) {
	hashTablePtr = ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(hashTablePtr, TCL_ONE_WORD_KEYS);
	Tcl_SetAssocData(interp, OPTION_HASH_KEY, DestroyOptionHashTable,
		hashTablePtr);
    }

    /*
     * See if a table has already been created for this template. If so, just
     * reuse the existing table.
     */

    hashEntryPtr = Tcl_CreateHashEntry(hashTablePtr, (char *) templatePtr,
	    &newEntry);
    if (!newEntry) {
	tablePtr = Tcl_GetHashValue(hashEntryPtr);
	tablePtr->refCount++;
	return (Tk_OptionTable) tablePtr;
    }

    /*
     * Count the number of options in the template, then create the table
     * structure.
     */

    numOptions = 0;
    for (specPtr = templatePtr; specPtr->type != TK_OPTION_END; specPtr++) {
	numOptions++;
    }
    tablePtr = ckalloc(sizeof(OptionTable) + (numOptions * sizeof(Option)));
    tablePtr->refCount = 1;
    tablePtr->refCount2 = 1;
    tablePtr->hashEntryPtr = hashEntryPtr;
    tablePtr->nextPtr = NULL;
    tablePtr->numOptions = numOptions;

    /*
     * Initialize all of the Option structures in the table.
     */

	if (((optionPtr->specPtr->type == TK_OPTION_COLOR)
		|| (optionPtr->specPtr->type == TK_OPTION_BORDER))
		&& (optionPtr->extra.monoColorPtr != NULL)) {
	    Tcl_DecrRefCount(optionPtr->extra.monoColorPtr);
	}
    }
    Tcl_DeleteHashEntry(tablePtr->hashEntryPtr);
    tablePtr->refCount2--;
    if (tablePtr->refCount2 <= 0) {
	ckfree(tablePtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * DestroyOptionHashTable --
 *
 *	This function is the deletion callback associated with the AssocData
 *	entry created by Tk_CreateOptionTable. It is invoked when an
 *	interpreter is deleted, and deletes all of the option tables
 *	associated with that interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The option hash table is destroyed along with all of the OptionTable
 *	structures that it refers to.
 *
 *----------------------------------------------------------------------
 */

static void
DestroyOptionHashTable(
    ClientData clientData,	/* The hash table we are destroying */
    Tcl_Interp *interp)		/* The interpreter we are destroying */
{
    Tcl_HashTable *hashTablePtr = clientData;
    Tcl_HashSearch search;
    Tcl_HashEntry *hashEntryPtr;

    for (hashEntryPtr = Tcl_FirstHashEntry(hashTablePtr, &search);
	    hashEntryPtr != NULL;
	    hashEntryPtr = Tcl_NextHashEntry(&search)) {
	OptionTable *tablePtr = Tcl_GetHashValue(hashEntryPtr);

	/*
	 * The following statements do two tricky things:
	 * 1. They ensure that the option table is deleted, even if there are
	 *    outstanding references to it.
	 * 2. They ensure that Tk_DeleteOptionTable doesn't delete other
	 *    tables chained from this one; we'll do it when we come across
	 *    the hash table entry for the chained table (in fact, the chained
	 *    table may already have been deleted).
	 */

	tablePtr->refCount = 1;
	tablePtr->nextPtr = NULL;
	Tk_DeleteOptionTable((Tk_OptionTable) tablePtr);
    }
    Tcl_DeleteHashTable(hashTablePtr);
    ckfree(hashTablePtr);
}

/*
 *--------------------------------------------------------------
 *
 * Tk_InitOptions --
 *

    if ((objPtr->typePtr != NULL)
	    && (objPtr->typePtr->freeIntRepProc != NULL)) {
	objPtr->typePtr->freeIntRepProc(objPtr);
    }
    objPtr->internalRep.twoPtrValue.ptr1 = (void *) tablePtr;
    objPtr->internalRep.twoPtrValue.ptr2 = (void *) bestPtr;
    objPtr->typePtr = &optionObjType;
    tablePtr->refCount2++;
    return bestPtr;

  error:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"unknown option \"%s\"", name));
	Tcl_SetErrorCode(interp, "TK", "LOOKUP", "OPTION", name, NULL);

 *----------------------------------------------------------------------
 */

static void
FreeOptionInternalRep(
    register Tcl_Obj *objPtr)	/* Object whose internal rep to free. */
{
    register OptionTable *tablePtr = (OptionTable *) objPtr->internalRep.twoPtrValue.ptr1;

    tablePtr->refCount2--;
    if (tablePtr->refCount2 <= 0) {
	ckfree(tablePtr);
    }
    objPtr->typePtr = NULL;
    objPtr->internalRep.twoPtrValue.ptr1 = NULL;
    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
}























/*
 *--------------------------------------------------------------
 *
 * Tk_SetOptions --
 *
 *	Process one or more name-value pairs for configuration options and

    Tcl_Interp *interp,		/* Interpreter in which the table is
				 * defined. */
    Tk_OptionTable table)	/* Table about which information is to be
				 * returned. May not necessarily exist in the
				 * interpreter anymore. */
{
    OptionTable *tablePtr = (OptionTable *) table;
    Tcl_HashTable *hashTablePtr;
    Tcl_HashEntry *hashEntryPtr;
    Tcl_HashSearch search;
    Tcl_Obj *objPtr;



    objPtr = Tcl_NewObj();
    hashTablePtr = Tcl_GetAssocData(interp, OPTION_HASH_KEY, NULL);
    if (hashTablePtr == NULL) {
	return objPtr;
    }

    /*
     * Scan all the tables for this interpreter to make sure that the one we
     * want still is valid.
     */

    for (hashEntryPtr = Tcl_FirstHashEntry(hashTablePtr, &search);
	    hashEntryPtr != NULL;
	    hashEntryPtr = Tcl_NextHashEntry(&search)) {
	if (tablePtr == (OptionTable *) Tcl_GetHashValue(hashEntryPtr)) {
	    for ( ; tablePtr != NULL; tablePtr = tablePtr->nextPtr) {
		Tcl_ListObjAppendElement(NULL, objPtr,
			Tcl_NewIntObj(tablePtr->refCount));
		Tcl_ListObjAppendElement(NULL, objPtr,

    deleteWindows
    testobjconfig delete chain3
    lappend x [testobjconfig info chain2] [testobjconfig info chain1]
    testobjconfig delete chain2
    lappend x [testobjconfig info chain2] [testobjconfig info chain1]
} -cleanup {
    killTables
} -result {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}}

# No tests for DestroyOptionHashTable; couldn't figure out how to test.

test config-3.1 {Tk_InitOptions - priority of chained tables} -constraints {
    testobjconfig
} -body {
    testobjconfig chain1 .a