Logo Search packages:      
Sourcecode: tcl8.0 version File versions  Download package

tclIndexObj.c

/* 
 * 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.2 1998/09/14 18:40:00 stanton 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);
}

Generated by  Doxygen 1.6.0   Back to index