itk_option.c

这是一个Linux下的集成开发环境

 *  Looks for an option table containing all of the class-based
 *  configuration options for a mega-widget.  These are the options
 *  included in a class definition which add new behavior to the
 *  mega-widget.
 *
 *  Returns a pointer to an option table which will contain pointers to
 *  Itk_ClassOption records.  If a table does not exist for this class,
 *  this returns NULL.
 * ------------------------------------------------------------------------
 */
ItkClassOptTable*
Itk_FindClassOptTable(cdefn)
    ItclClass *cdefn;          /* class definition */
{
    Tcl_HashTable *itkClasses;
    Tcl_HashEntry *entry;

    /*
     *  Look for the specified class definition in the table.
     */
    itkClasses = ItkGetClassesWithOptInfo(cdefn->interp);
    entry = Tcl_FindHashEntry(itkClasses, (char*)cdefn);
    if (entry) {
        return (ItkClassOptTable*)Tcl_GetHashValue(entry);
    }
    return NULL;
}


/*
 * ------------------------------------------------------------------------
 *  ItkTraceClassDestroy()
 *
 *  Invoked automatically whenever the "_itk_option_data" variable
 *  is destroyed within a class namespace.  This should be a signal
 *  that the namespace is being destroyed.
 *
 *  Releases any option data that exists for the class.
 *
 *  Returns NULL on success, or a pointer to a string describing any
 *  error that is encountered.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static char*
ItkTraceClassDestroy(cdata, interp, name1, name2, flags)
    ClientData cdata;          /* class definition data */
    Tcl_Interp *interp;        /* interpreter managing the class */
    char *name1;               /* name of variable involved in trace */
    char *name2;               /* name of array element within variable */
    int flags;                 /* flags describing trace */
{
    ItclClass *cdefn = (ItclClass*)cdata;

    Tcl_HashTable *itkClasses;
    Tcl_HashEntry *entry;
    ItkClassOptTable *optTable;
    Tcl_HashSearch place;
    ItkClassOption *opt;

    /*
     *  Look for the specified class definition in the table.
     *  If it is found, delete all the option records and tear
     *  down the table.
     */
    itkClasses = ItkGetClassesWithOptInfo(cdefn->interp);
    entry = Tcl_FindHashEntry(itkClasses, (char*)cdefn);
    if (entry) {
        optTable = (ItkClassOptTable*)Tcl_GetHashValue(entry);
        Tcl_DeleteHashEntry(entry);

        entry = Tcl_FirstHashEntry(&optTable->options, &place);
        while (entry) {
            opt = (ItkClassOption*)Tcl_GetHashValue(entry);
            Itk_DelClassOption(opt);
            entry = Tcl_NextHashEntry(&place);
        }
        Tcl_DeleteHashTable(&optTable->options);
        Itk_OptListFree(&optTable->order);
        ckfree((char*)optTable);
    }
    return NULL;
}


/*
 * ------------------------------------------------------------------------
 *  Itk_CreateClassOption()
 *
 *  Creates the data representing a configuration option for an
 *  Archetype mega-widget.  This record represents an option included
 *  in the class definition.  It adds new behavior to the mega-widget
 *  class.
 *
 *  If successful, returns TCL_OK along with a pointer to the option
 *  record.  Returns TCL_ERROR (along with an error message in the
 *  interpreter) if anything goes wrong.
 * ------------------------------------------------------------------------
 */
int
Itk_CreateClassOption(interp, cdefn, switchName, resName, resClass,
    defVal, config, optPtr)

    Tcl_Interp *interp;            /* interpreter managing the class */
    ItclClass *cdefn;              /* class containing this option */
    char *switchName;              /* name of command-line switch */
    char *resName;                 /* resource name in X11 database */
    char *resClass;                /* resource class name in X11 database */
    char *defVal;                  /* last-resort default value */
    char *config;                  /* configuration code */
    ItkClassOption **optPtr;       /* returns: option record */
{
    ItkClassOption *opt;
    ItclMemberCode *mcode;

    /*
     *  If this option has any "config" code, then try to create
     *  an implementation for it.
     */
    if (config) {
        if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, config,
            &mcode) != TCL_OK) {

            return TCL_ERROR;
        }
        Itcl_PreserveData((ClientData)mcode);
        Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
    }
    else {
        mcode = NULL;
    }

    /*
     *  Create the record to represent this option.
     */
    opt = (ItkClassOption*)ckalloc(sizeof(ItkClassOption));
    opt->member = Itcl_CreateMember(interp, cdefn, switchName);
    opt->member->code = mcode;

    opt->resName = (char*)ckalloc((unsigned)(strlen(resName)+1));
    strcpy(opt->resName, resName);

    opt->resClass = (char*)ckalloc((unsigned)(strlen(resClass)+1));
    strcpy(opt->resClass, resClass);

    opt->init = (char*)ckalloc((unsigned)(strlen(defVal)+1));
    strcpy(opt->init, defVal);

    *optPtr = opt;
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itk_FindClassOption()
 *
 *  Searches for a class-based configuration option for an Archetype
 *  mega-widget.   The specified name is treated as the "switch" name
 *  (e.g., "-option"), but this procedure will recognize it even without
 *  the leading "-".
 *
 *  If an option is found that was defined in the specified class,
 *  then this procedure returns a pointer to the option definition.
 *  Otherwise, it returns NULL.
 * ------------------------------------------------------------------------
 */
ItkClassOption*
Itk_FindClassOption(cdefn, switchName)
    ItclClass *cdefn;              /* class containing this option */
    char *switchName;              /* name of command-line switch */
{
    ItkClassOption *opt = NULL;

    Tcl_DString buffer;
    ItkClassOptTable *optTable;
    Tcl_HashEntry *entry;

    /*
     *  If the switch does not have a leading "-", add it on.
     */
    Tcl_DStringInit(&buffer);
    if (*switchName != '-') {
        Tcl_DStringAppend(&buffer, "-", -1);
        Tcl_DStringAppend(&buffer, switchName, -1);
        switchName = Tcl_DStringValue(&buffer);
    }

    /*
     *  Look for the option table for the specified class, and check
     *  for the requested switch.
     */
    optTable = Itk_FindClassOptTable(cdefn);
    if (optTable) {
        entry = Tcl_FindHashEntry(&optTable->options, switchName);
        if (entry) {
            opt = (ItkClassOption*)Tcl_GetHashValue(entry);
        }
    }
    Tcl_DStringFree(&buffer);
    return opt;
}

/*
 * ------------------------------------------------------------------------
 *  Itk_DelClassOption()
 *
 *  Destroys a configuration option previously created by
 *  Itk_CreateClassOption().
 * ------------------------------------------------------------------------
 */
void
Itk_DelClassOption(opt)
    ItkClassOption *opt;  /* pointer to option data */
{
    Itcl_DeleteMember(opt->member);
    ckfree(opt->resName);
    ckfree(opt->resClass);
    ckfree(opt->init);

    ckfree((char*)opt);
}


/*
 * ------------------------------------------------------------------------
 *  ItkGetClassesWithOptInfo()
 *
 *  Returns a pointer to a hash table containing the list of registered
 *  classes in the specified interpreter.  If the hash table does not
 *  already exist, it is created.
 * ------------------------------------------------------------------------
 */
static Tcl_HashTable*
ItkGetClassesWithOptInfo(interp)
    Tcl_Interp *interp;  /* interpreter handling this registration */
{
    Tcl_HashTable* classesTable;

    /*
     *  If the registration table does not yet exist, then create it.
     */
    classesTable = (Tcl_HashTable*)Tcl_GetAssocData(interp,
        "itk_classesWithOptInfo", (Tcl_InterpDeleteProc**)NULL);

    if (!classesTable) {
        classesTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
        Tcl_InitHashTable(classesTable, TCL_ONE_WORD_KEYS);
        Tcl_SetAssocData(interp, "itk_classesWithOptInfo",
            ItkFreeClassesWithOptInfo, (ClientData)classesTable);
    }
    return classesTable;
}

/*
 * ------------------------------------------------------------------------
 *  ItkFreeClassesWithOptInfo()
 *
 *  When an interpreter is deleted, this procedure is called to
 *  free up the associated data created by ItkGetClassesWithOptInfo.
 * ------------------------------------------------------------------------
 */
static void
ItkFreeClassesWithOptInfo(clientData, interp)
    ClientData clientData;       /* associated data */
    Tcl_Interp *interp;          /* interpreter being freed */
{
    Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData;
    Tcl_HashSearch place, place2;
    Tcl_HashEntry *entry, *entry2;
    ItkClassOptTable *optTable;
    ItkClassOption *opt;

    entry = Tcl_FirstHashEntry(tablePtr, &place);
    while (entry) {
        optTable = (ItkClassOptTable*)Tcl_GetHashValue(entry);

        entry2 = Tcl_FirstHashEntry(&optTable->options, &place2);
        while (entry2) {
            opt = (ItkClassOption*)Tcl_GetHashValue(entry2);
            Itk_DelClassOption(opt);
            entry2 = Tcl_NextHashEntry(&place2);
        }
        Tcl_DeleteHashTable(&optTable->options);
        Itk_OptListFree(&optTable->order);
        ckfree((char*)optTable);

        entry = Tcl_NextHashEntry(&place);
    }

    Tcl_DeleteHashTable(tablePtr);
    ckfree((char*)tablePtr);
}