Subversion Repositories or1k

/*

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

 *      PACKAGE:  [incr Tk]

 *  DESCRIPTION:  Building mega-widgets with [incr Tcl]

 *

 *  [incr Tk] provides a framework for building composite "mega-widgets"

 *  using [incr Tcl] classes.  It defines a set of base classes that are

 *  specialized to create all other widgets.

 *

 *  This file defines procedures used to manage mega-widget options

 *  specified within class definitions.

 *

 * ========================================================================

 *  AUTHOR:  Michael J. McLennan

 *           Bell Labs Innovations for Lucent Technologies

 *           mmclennan@lucent.com

 *           http://www.tcltk.com/itcl

 *

 *     RCS:  $Id: itk_option.c,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $

 * ========================================================================

 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.

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

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

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

 */

#include "itk.h"

/*

 *  FORWARD DECLARATIONS

 */

static char* ItkTraceClassDestroy _ANSI_ARGS_((ClientData cdata,

    Tcl_Interp *interp, char *name1, char *name2, int flags));

static Tcl_HashTable* ItkGetClassesWithOptInfo _ANSI_ARGS_((

    Tcl_Interp *interp));

static void ItkFreeClassesWithOptInfo _ANSI_ARGS_((ClientData cdata,

    Tcl_Interp *interp));

/*

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

 *  Itk_ClassOptionDefineCmd()

 *

 *  Invoked when a class definition is being parse to handle an

 *  itk_option declaration.  Adds a new option to a mega-widget

 *  declaration, with some code that will be executed whenever the

 *  option is changed via "configure".  If there is already an existing

 *  option by that name, then this new option is folded into the

 *  existing option, but the <init> value is ignored.  The X11 resource

 *  database names must be consistent with the existing option.

 *

 *  Handles the following syntax:

 *

 *      itk_option define <switch> <resName> <resClass> <init> ?<config>?

 *

 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.

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

 */

/* ARGSUSED */

int

Itk_ClassOptionDefineCmd(clientData, interp, objc, objv)

    ClientData clientData;   /* class parser info */

    Tcl_Interp *interp;      /* current interpreter */

    int objc;                /* number of arguments */

    Tcl_Obj *CONST objv[];   /* argument objects */

{

    ItclObjectInfo *info = (ItclObjectInfo*)clientData;

    ItclClass *cdefn = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);

    int newEntry;

    char *switchName, *resName, *resClass, *init, *config;

    ItkClassOptTable *optTable;

    Tcl_HashEntry *entry;

    ItkClassOption *opt;

    /*

     *  Make sure that the arguments look right.  The option switch

     *  name must start with a '-'.

     */

    if (objc < 5 || objc > 6) {

        Tcl_WrongNumArgs(interp, 1, objv,

            "-switch resourceName resourceClass init ?config?");

        return TCL_ERROR;

    }

    switchName = Tcl_GetStringFromObj(objv[1], (int*)NULL);

    if (*switchName != '-') {

        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),

            "bad option name \"", switchName, "\": should be -", switchName,

            (char*)NULL);

        return TCL_ERROR;

    }

    if (strstr(switchName, ".")) {

        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),

            "bad option name \"", switchName, "\": illegal character \".\"",

            (char*)NULL);

        return TCL_ERROR;

    }

    resName = Tcl_GetStringFromObj(objv[2], (int*)NULL);

    if (!islower((int)*resName)) {

        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),

            "bad resource name \"", resName,

            "\": should start with a lower case letter",

            (char*)NULL);

        return TCL_ERROR;

    }

    resClass = Tcl_GetStringFromObj(objv[3], (int*)NULL);

    if (!isupper((int)*resClass)) {

        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),

            "bad resource class \"", resClass,

            "\": should start with an upper case letter",

            (char*)NULL);

        return TCL_ERROR;

    }

    /*

     *  Make sure that this option has not already been defined in

     *  the context of this class.  Options can be redefined in

     *  other classes, but can only be defined once in a given

     *  class.  This ensures that there will be no confusion about

     *  which option is being referenced if the configuration code

     *  is redefined by a subsequent "body" command.

     */

    optTable = Itk_CreateClassOptTable(interp, cdefn);

    entry = Tcl_CreateHashEntry(&optTable->options, switchName, &newEntry);

    if (!newEntry) {

        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),

            "option \"", switchName, "\" already defined in class \"",

            cdefn->fullname, "\"",

            (char*)NULL);

        return TCL_ERROR;

    }

    /*

     *  Create a new option record and add it to the table for this

     *  class.

     */

    init = Tcl_GetStringFromObj(objv[4], (int*)NULL);

    if (objc == 6) {

        config = Tcl_GetStringFromObj(objv[5], (int*)NULL);

    } else {

        config = NULL;

    }

    if (Itk_CreateClassOption(interp, cdefn, switchName, resName, resClass,

        init, config, &opt) != TCL_OK) {

        return TCL_ERROR;

    }

    Tcl_SetHashValue(entry, (ClientData)opt);

    Itk_OptListAdd(&optTable->order, entry);

    return TCL_OK;

}

/*

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

 *  Itk_ClassOptionIllegalCmd()

 *

 *  Invoked when a class definition is being parse to handle an

 *  itk_option declaration.  Handles an "illegal" declaration like

 *  "add" or "remove", which can only be used after a widget has

 *  been created.  Returns TCL_ERROR along with an error message.

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

 */

/* ARGSUSED */

int

Itk_ClassOptionIllegalCmd(clientData, interp, objc, objv)

    ClientData clientData;   /* class parser info */

    Tcl_Interp *interp;      /* current interpreter */

    int objc;                /* number of arguments */

    Tcl_Obj *CONST objv[];   /* argument objects */

{

    char *op = Tcl_GetStringFromObj(objv[0], (int*)NULL);

    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),

        "can only ", op, " options for a specific widget\n",

        "(move this command into the constructor)",

        (char*)NULL);

    return TCL_ERROR;

}

/*

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

 *  Itk_ConfigClassOption()

 *

 *  Invoked whenever a class-based configuration option has been

 *  configured with a new value.  If the option has any extra code

 *  associated with it, the code is invoked at this point to bring

 *  the widget up-to-date.

 *

 *  Returns TCL_OK on success, or TCL_ERROR (along with an error

 *  message in the interpreter) if anything goes wrong.

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

 */

/* ARGSUSED */

int

Itk_ConfigClassOption(interp, contextObj, cdata, newval)

    Tcl_Interp *interp;        /* interpreter managing the class */

    ItclObject *contextObj;    /* object being configured */

    ClientData cdata;          /* class option */

    char *newval;              /* new value for this option */

{

    ItkClassOption *opt = (ItkClassOption*)cdata;

    int result = TCL_OK;

    ItclMemberCode *mcode;

    /*

     *  If the option has any config code, execute it now.

     *  Make sure that the namespace context is set up correctly.

     */

    mcode = opt->member->code;

    if (mcode && mcode->procPtr->bodyPtr) {

        result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL,

            opt->member, contextObj, 0, (Tcl_Obj**)NULL);

    }

    return result;

}

/*

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

 *  Itk_CreateClassOptTable()

 *

 *  Finds or creates an option table which will contain all of the

 *  class-based configuration options for a mega-widget.  These are

 *  the options included in the class definition which add new behavior

 *  to the mega-widget.

 *

 *  This table is automatically deleted by ItkTraceClassDestroy

 *  whenever the class namespace is destroyed.  The "unset" operation

 *  of a private class variable is used to detect the destruction of

 *  the namespace.

 *

 *  Returns a pointer to an option table which will contain pointers to

 *  ItkClassOption records.

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

 */

ItkClassOptTable*

Itk_CreateClassOptTable(interp, cdefn)

    Tcl_Interp *interp;        /* interpreter managing the class */

    ItclClass *cdefn;          /* class definition */

{

    int newEntry, result;

    Tcl_HashTable *itkClasses;

    Tcl_HashEntry *entry;

    ItkClassOptTable *optTable;

    Tcl_CallFrame frame;

    /*

     *  Look for the specified class definition in the table.

     *  If it does not yet exist, then create a new slot for it.

     *  When a table is created for the first time, add a

     *  special sentinel variable "_itk_option_data" to the

     *  class namespace, and put a trace on this variable.

     *  Whenever it is destroyed, have it delete the option table

     *  for this class.

     */

    itkClasses = ItkGetClassesWithOptInfo(interp);

    entry = Tcl_CreateHashEntry(itkClasses, (char*)cdefn, &newEntry);

    if (newEntry) {

        optTable = (ItkClassOptTable*)ckalloc(sizeof(ItkClassOptTable));

        Tcl_InitHashTable(&optTable->options, TCL_STRING_KEYS);

        Itk_OptListInit(&optTable->order, &optTable->options);

        Tcl_SetHashValue(entry, (ClientData)optTable);

        result = Tcl_PushCallFrame(interp, &frame,

             cdefn->namesp, /* isProcCallFrame */ 0);

        if (result == TCL_OK) {

            Tcl_TraceVar(interp, "_itk_option_data",

                (TCL_TRACE_UNSETS | TCL_NAMESPACE_ONLY),

                ItkTraceClassDestroy, (ClientData)cdefn);

            Tcl_PopCallFrame(interp);

        }

    }

    else {

        optTable = (ItkClassOptTable*)Tcl_GetHashValue(entry);

    }

    return optTable;

}

/*

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

 *  Itk_FindClassOptTable()

 *

 *  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);

}