summaryrefslogtreecommitdiffstats
path: root/generic/tclIndexObj.c
diff options
context:
space:
mode:
authorrjohnson <rjohnson>1998-03-26 14:45:59 (GMT)
committerrjohnson <rjohnson>1998-03-26 14:45:59 (GMT)
commit2b5738da524e944cda39e24c0a87b745a43bd8c3 (patch)
tree6e8c9473978f6dab66c601e911721a7bd9d70b1b /generic/tclIndexObj.c
parentc6a259aeeca4814a97cf6694814c63e74e4e18fa (diff)
downloadtcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.zip
tcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.tar.gz
tcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.tar.bz2
Initial revision
Diffstat (limited to 'generic/tclIndexObj.c')
-rw-r--r--generic/tclIndexObj.c308
1 files changed, 308 insertions, 0 deletions
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
new file mode 100644
index 0000000..824270a
--- /dev/null
+++ b/generic/tclIndexObj.c
@@ -0,0 +1,308 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclIndexObj.c 1.8 97/07/29 10:16:54
+ */
+
+#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);
+}