Subversion Repositories or1k

/*

 * tclIndexObj.c --

 *

 *      This file implements objects of type "index".  This object type

 *      is used to lookup a keyword in a table of valid values and cache

 *      the index of the matching entry.

 *

 * Copyright (c) 1997 Sun Microsystems, Inc.

 *

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

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

 *

 * RCS: @(#) $Id: tclIndexObj.c,v 1.1.1.1 2002-01-16 10:25:27 markom Exp $

 */

#include "tclInt.h"

/*

 * Prototypes for procedures defined later in this file:

 */

static void             DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,

                            Tcl_Obj *copyPtr));

static int              SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,

                            Tcl_Obj *objPtr));

static void             UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr));

/*

 * The structure below defines the index Tcl object type by means of

 * procedures that can be invoked by generic object code.

 */

Tcl_ObjType tclIndexType = {

    "index",                            /* name */

    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */

    DupIndexInternalRep,                /* dupIntRepProc */

    UpdateStringOfIndex,                /* updateStringProc */

    SetIndexFromAny                     /* setFromAnyProc */

};

/*

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

 *

 * Tcl_GetIndexFromObj --

 *

 *      This procedure looks up an object's value in a table of strings

 *      and returns the index of the matching string, if any.

 *

 * Results:

 *      If the value of objPtr is identical to or a unique abbreviation

 *      for one of the entries in objPtr, then the return value is

 *      TCL_OK and the index of the matching entry is stored at

 *      *indexPtr.  If there isn't a proper match, then TCL_ERROR is

 *      returned and an error message is left in interp's result (unless

 *      interp is NULL).  The msg argument is used in the error

 *      message; for example, if msg has the value "option" then the

 *      error message will say something flag 'bad option "foo": must be

 *      ...'

 *

 * Side effects:

 *      The result of the lookup is cached as the internal rep of

 *      objPtr, so that repeated lookups can be done quickly.

 *

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

 */

int

Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)

    Tcl_Interp *interp;         /* Used for error reporting if not NULL. */

    Tcl_Obj *objPtr;            /* Object containing the string to lookup. */

    char **tablePtr;            /* Array of strings to compare against the

                                 * value of objPtr; last entry must be NULL

                                 * and there must not be duplicate entries. */

    char *msg;                  /* Identifying word to use in error messages. */

    int flags;                  /* 0 or TCL_EXACT */

    int *indexPtr;              /* Place to store resulting integer index. */

{

    int index, length, i, numAbbrev;

    char *key, *p1, *p2, **entryPtr;

    Tcl_Obj *resultPtr;

    /*

     * See if there is a valid cached result from a previous lookup.

     */

    if ((objPtr->typePtr == &tclIndexType)

            && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {

        *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;

        return TCL_OK;

    }

    /*

     * Lookup the value of the object in the table.  Accept unique

     * abbreviations unless TCL_EXACT is set in flags.

     */

    key = Tcl_GetStringFromObj(objPtr, &length);

    index = -1;

    numAbbrev = 0;

    for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) {

        for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {

            if (*p1 == 0) {

                index = i;

                goto done;

            }

        }

        if (*p1 == 0) {

            /*

             * The value is an abbreviation for this entry.  Continue

             * checking other entries to make sure it's unique.  If we

             * get more than one unique abbreviation, keep searching to

             * see if there is an exact match, but remember the number

             * of unique abbreviations and don't allow either.

             */

            numAbbrev++;

            index = i;

        }

    }

    if ((flags & TCL_EXACT) || (numAbbrev != 1)) {

        goto error;

    }

    done:

    if ((objPtr->typePtr != NULL)

            && (objPtr->typePtr->freeIntRepProc != NULL)) {

        objPtr->typePtr->freeIntRepProc(objPtr);

    }

    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;

    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) index;

    objPtr->typePtr = &tclIndexType;

    *indexPtr = index;

    return TCL_OK;

    error:

    if (interp != NULL) {

        resultPtr = Tcl_GetObjResult(interp);

        Tcl_AppendStringsToObj(resultPtr,

                (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",

                key, "\": must be ", *tablePtr, (char *) NULL);

        for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) {

            if (entryPtr[1] == NULL) {

                Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr,

                        (char *) NULL);

            } else {

                Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,

                        (char *) NULL);

            }

        }

    }

    return TCL_ERROR;

}

/*

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

 *

 * DupIndexInternalRep --

 *

 *      Copy the internal representation of an index Tcl_Obj from one

 *      object to another.

 *

 * Results:

 *      None.

 *

 * Side effects:

 *      "copyPtr"s internal rep is set to same value as "srcPtr"s

 *      internal rep.

 *

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

 */

static void

DupIndexInternalRep(srcPtr, copyPtr)

    register Tcl_Obj *srcPtr;   /* Object with internal rep to copy. */

    register Tcl_Obj *copyPtr;  /* Object with internal rep to set. */

{

    copyPtr->internalRep.twoPtrValue.ptr1

            = srcPtr->internalRep.twoPtrValue.ptr1;

    copyPtr->internalRep.twoPtrValue.ptr2

            = srcPtr->internalRep.twoPtrValue.ptr2;

    copyPtr->typePtr = &tclIndexType;

}

/*

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

 *

 * SetIndexFromAny --

 *

 *      This procedure is called to convert a Tcl object to index

 *      internal form. However, this doesn't make sense (need to have a

 *      table of keywords in order to do the conversion) so the

 *      procedure always generates an error.

 *

 * Results:

 *      The return value is always TCL_ERROR, and an error message is

 *      left in interp's result if interp isn't NULL.

 *

 * Side effects:

 *      None.

 *

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

 */

static int

SetIndexFromAny(interp, objPtr)

    Tcl_Interp *interp;         /* Used for error reporting if not NULL. */

    register Tcl_Obj *objPtr;   /* The object to convert. */

{

    Tcl_AppendToObj(Tcl_GetObjResult(interp),

            "can't convert value to index except via Tcl_GetIndexFromObj API",

            -1);

    return TCL_ERROR;

}

/*

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

 *

 * UpdateStringOfIndex --

 *

 *      This procedure is called to update the string representation for

 *      an index object.  It should never be called, because we never

 *      invalidate the string representation for an index object.

 *

 * Results:

 *      None.

 *

 * Side effects:

 *      A panic is added

 *

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

 */

static void

UpdateStringOfIndex(objPtr)

    register Tcl_Obj *objPtr;   /* Int object whose string rep to update. */

{

    panic("UpdateStringOfIndex should never be invoked");

}

/*

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

 *

 * Tcl_WrongNumArgs --

 *

 *      This procedure generates a "wrong # args" error message in an

 *      interpreter.  It is used as a utility function by many command

 *      procedures.

 *

 * Results:

 *      None.

 *

 * Side effects:

 *      An error message is generated in interp's result object to

 *      indicate that a command was invoked with the wrong number of

 *      arguments.  The message has the form

 *              wrong # args: should be "foo bar additional stuff"

 *      where "foo" and "bar" are the initial objects in objv (objc

 *      determines how many of these are printed) and "additional stuff"

 *      is the contents of the message argument.

 *

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

 */

void

Tcl_WrongNumArgs(interp, objc, objv, message)

    Tcl_Interp *interp;                 /* Current interpreter. */

    int objc;                           /* Number of arguments to print

                                         * from objv. */

    Tcl_Obj *CONST objv[];              /* Initial argument objects, which

                                         * should be included in the error

                                         * message. */

    char *message;                      /* Error message to print after the

                                         * leading objects in objv. The

                                         * message may be NULL. */

{

    Tcl_Obj *objPtr;

    char **tablePtr;

    int i;

    objPtr = Tcl_GetObjResult(interp);

    Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);

    for (i = 0; i < objc; i++) {

        /*

         * If the object is an index type use the index table which allows

         * for the correct error message even if the subcommand was

         * abbreviated.  Otherwise, just use the string rep.

         */

        if (objv[i]->typePtr == &tclIndexType) {

            tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);

            Tcl_AppendStringsToObj(objPtr,

                    tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],

                    (char *) NULL);

        } else {

            Tcl_AppendStringsToObj(objPtr,

                    Tcl_GetStringFromObj(objv[i], (int *) NULL),

                    (char *) NULL);

        }

        if (i < (objc - 1)) {

            Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);

        }

    }

    if (message) {

      Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);

    }

    Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);

}