itk_option.c

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

/*
 * ------------------------------------------------------------------------
 *      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
 *           [e-mail]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itk_option.c,v 1.1 2003/02/05 10:53:59 mdejong 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()
 *