home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclIndexObj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  9.1 KB  |  309 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclIndexObj.c --
  3.  *
  4.  *    This file implements objects of type "index".  This object type
  5.  *    is used to lookup a keyword in a table of valid values and cache
  6.  *    the index of the matching entry.
  7.  *
  8.  * Copyright (c) 1997 Sun Microsystems, Inc.
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  *
  13.  * SCCS: @(#) tclIndexObj.c 1.8 97/07/29 10:16:54
  14.  */
  15.  
  16. #include "tclInt.h"
  17.  
  18. /*
  19.  * Prototypes for procedures defined later in this file:
  20.  */
  21.  
  22. static void        DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
  23.                 Tcl_Obj *copyPtr));
  24. static int        SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
  25.                 Tcl_Obj *objPtr));
  26. static void        UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr));
  27.  
  28. /*
  29.  * The structure below defines the index Tcl object type by means of
  30.  * procedures that can be invoked by generic object code.
  31.  */
  32.  
  33. Tcl_ObjType tclIndexType = {
  34.     "index",                /* name */
  35.     (Tcl_FreeInternalRepProc *) NULL,    /* freeIntRepProc */
  36.     DupIndexInternalRep,            /* dupIntRepProc */
  37.     UpdateStringOfIndex,        /* updateStringProc */
  38.     SetIndexFromAny            /* setFromAnyProc */
  39. };
  40.  
  41. /*
  42.  *----------------------------------------------------------------------
  43.  *
  44.  * Tcl_GetIndexFromObj --
  45.  *
  46.  *    This procedure looks up an object's value in a table of strings
  47.  *    and returns the index of the matching string, if any.
  48.  *
  49.  * Results:
  50.  
  51.  *    If the value of objPtr is identical to or a unique abbreviation
  52.  *    for one of the entries in objPtr, then the return value is
  53.  *    TCL_OK and the index of the matching entry is stored at
  54.  *    *indexPtr.  If there isn't a proper match, then TCL_ERROR is
  55.  *    returned and an error message is left in interp's result (unless
  56.  *    interp is NULL).  The msg argument is used in the error
  57.  *    message; for example, if msg has the value "option" then the
  58.  *    error message will say something flag 'bad option "foo": must be
  59.  *    ...'
  60.  *
  61.  * Side effects:
  62.  *    The result of the lookup is cached as the internal rep of
  63.  *    objPtr, so that repeated lookups can be done quickly.
  64.  *
  65.  *----------------------------------------------------------------------
  66.  */
  67.  
  68. int
  69. Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
  70.     Tcl_Interp *interp;     /* Used for error reporting if not NULL. */
  71.     Tcl_Obj *objPtr;        /* Object containing the string to lookup. */
  72.     char **tablePtr;        /* Array of strings to compare against the
  73.                  * value of objPtr; last entry must be NULL
  74.                  * and there must not be duplicate entries. */
  75.     char *msg;            /* Identifying word to use in error messages. */
  76.     int flags;            /* 0 or TCL_EXACT */
  77.     int *indexPtr;        /* Place to store resulting integer index. */
  78. {
  79.     int index, length, i, numAbbrev;
  80.     char *key, *p1, *p2, **entryPtr;
  81.     Tcl_Obj *resultPtr;
  82.  
  83.     /*
  84.      * See if there is a valid cached result from a previous lookup.
  85.      */
  86.  
  87.     if ((objPtr->typePtr == &tclIndexType)
  88.         && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
  89.     *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
  90.     return TCL_OK;
  91.     }
  92.  
  93.     /*
  94.      * Lookup the value of the object in the table.  Accept unique
  95.      * abbreviations unless TCL_EXACT is set in flags.
  96.      */
  97.  
  98.     key = Tcl_GetStringFromObj(objPtr, &length);
  99.     index = -1;
  100.     numAbbrev = 0;
  101.     for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) {
  102.     for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
  103.         if (*p1 == 0) {
  104.         index = i;
  105.         goto done;
  106.         }
  107.     }
  108.     if (*p1 == 0) {
  109.         /*
  110.          * The value is an abbreviation for this entry.  Continue
  111.          * checking other entries to make sure it's unique.  If we
  112.          * get more than one unique abbreviation, keep searching to
  113.          * see if there is an exact match, but remember the number
  114.          * of unique abbreviations and don't allow either.
  115.          */
  116.  
  117.         numAbbrev++;
  118.         index = i;
  119.     }
  120.     }
  121.     if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
  122.     goto error;
  123.     }
  124.  
  125.     done:
  126.     if ((objPtr->typePtr != NULL)
  127.         && (objPtr->typePtr->freeIntRepProc != NULL)) {
  128.     objPtr->typePtr->freeIntRepProc(objPtr);
  129.     }
  130.     objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;
  131.     objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
  132.     objPtr->typePtr = &tclIndexType;
  133.     *indexPtr = index;
  134.     return TCL_OK;
  135.  
  136.     error:
  137.     if (interp != NULL) {
  138.     resultPtr = Tcl_GetObjResult(interp);
  139.     Tcl_AppendStringsToObj(resultPtr,
  140.         (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
  141.         key, "\": must be ", *tablePtr, (char *) NULL);
  142.     for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) {
  143.         if (entryPtr[1] == NULL) {
  144.         Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr,
  145.             (char *) NULL);
  146.         } else {
  147.         Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
  148.             (char *) NULL);
  149.         }
  150.     }
  151.     }
  152.     return TCL_ERROR;
  153. }
  154.  
  155. /*
  156.  *----------------------------------------------------------------------
  157.  *
  158.  * DupIndexInternalRep --
  159.  *
  160.  *    Copy the internal representation of an index Tcl_Obj from one
  161.  *    object to another.
  162.  *
  163.  * Results:
  164.  *    None.
  165.  *
  166.  * Side effects:
  167.  *    "copyPtr"s internal rep is set to same value as "srcPtr"s
  168.  *    internal rep.
  169.  *
  170.  *----------------------------------------------------------------------
  171.  */
  172.  
  173. static void
  174. DupIndexInternalRep(srcPtr, copyPtr)
  175.     register Tcl_Obj *srcPtr;    /* Object with internal rep to copy. */
  176.     register Tcl_Obj *copyPtr;    /* Object with internal rep to set. */
  177. {
  178.     copyPtr->internalRep.twoPtrValue.ptr1
  179.         = srcPtr->internalRep.twoPtrValue.ptr1;
  180.     copyPtr->internalRep.twoPtrValue.ptr2
  181.         = srcPtr->internalRep.twoPtrValue.ptr2;
  182.     copyPtr->typePtr = &tclIndexType;
  183. }
  184.  
  185. /*
  186.  *----------------------------------------------------------------------
  187.  *
  188.  * SetIndexFromAny --
  189.  *
  190.  *    This procedure is called to convert a Tcl object to index
  191.  *    internal form. However, this doesn't make sense (need to have a
  192.  *    table of keywords in order to do the conversion) so the
  193.  *    procedure always generates an error.
  194.  *
  195.  * Results:
  196.  *    The return value is always TCL_ERROR, and an error message is
  197.  *    left in interp's result if interp isn't NULL. 
  198.  *
  199.  * Side effects:
  200.  *    None.
  201.  *
  202.  *----------------------------------------------------------------------
  203.  */
  204.  
  205. static int
  206. SetIndexFromAny(interp, objPtr)
  207.     Tcl_Interp *interp;        /* Used for error reporting if not NULL. */
  208.     register Tcl_Obj *objPtr;    /* The object to convert. */
  209. {
  210.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  211.         "can't convert value to index except via Tcl_GetIndexFromObj API",
  212.         -1);
  213.     return TCL_ERROR;
  214. }
  215.  
  216. /*
  217.  *----------------------------------------------------------------------
  218.  *
  219.  * UpdateStringOfIndex --
  220.  *
  221.  *    This procedure is called to update the string representation for
  222.  *    an index object.  It should never be called, because we never
  223.  *    invalidate the string representation for an index object.
  224.  *
  225.  * Results:
  226.  *    None.
  227.  *
  228.  * Side effects:
  229.  *    A panic is added
  230.  *
  231.  *----------------------------------------------------------------------
  232.  */
  233.  
  234. static void
  235. UpdateStringOfIndex(objPtr)
  236.     register Tcl_Obj *objPtr;    /* Int object whose string rep to update. */
  237. {
  238.     panic("UpdateStringOfIndex should never be invoked");
  239. }
  240.  
  241. /*
  242.  *----------------------------------------------------------------------
  243.  *
  244.  * Tcl_WrongNumArgs --
  245.  *
  246.  *    This procedure generates a "wrong # args" error message in an
  247.  *    interpreter.  It is used as a utility function by many command
  248.  *    procedures.
  249.  *
  250.  * Results:
  251.  *    None.
  252.  *
  253.  * Side effects:
  254.  *    An error message is generated in interp's result object to
  255.  *    indicate that a command was invoked with the wrong number of
  256.  *    arguments.  The message has the form
  257.  *        wrong # args: should be "foo bar additional stuff"
  258.  *    where "foo" and "bar" are the initial objects in objv (objc
  259.  *    determines how many of these are printed) and "additional stuff"
  260.  *    is the contents of the message argument.
  261.  *
  262.  *----------------------------------------------------------------------
  263.  */
  264.  
  265. void
  266. Tcl_WrongNumArgs(interp, objc, objv, message)
  267.     Tcl_Interp *interp;            /* Current interpreter. */
  268.     int objc;                /* Number of arguments to print
  269.                      * from objv. */
  270.     Tcl_Obj *CONST objv[];        /* Initial argument objects, which
  271.                      * should be included in the error
  272.                      * message. */
  273.     char *message;            /* Error message to print after the
  274.                      * leading objects in objv. The
  275.                      * message may be NULL. */
  276. {
  277.     Tcl_Obj *objPtr;
  278.     char **tablePtr;
  279.     int i;
  280.  
  281.     objPtr = Tcl_GetObjResult(interp);
  282.     Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
  283.     for (i = 0; i < objc; i++) {
  284.     /*
  285.      * If the object is an index type use the index table which allows
  286.      * for the correct error message even if the subcommand was
  287.      * abbreviated.  Otherwise, just use the string rep.
  288.      */
  289.     
  290.     if (objv[i]->typePtr == &tclIndexType) {
  291.         tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);
  292.         Tcl_AppendStringsToObj(objPtr,
  293.             tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
  294.             (char *) NULL);
  295.     } else {
  296.         Tcl_AppendStringsToObj(objPtr,
  297.             Tcl_GetStringFromObj(objv[i], (int *) NULL),
  298.             (char *) NULL);
  299.     }
  300.     if (i < (objc - 1)) {
  301.         Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
  302.     }
  303.     }
  304.     if (message) {
  305.       Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
  306.     }
  307.     Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
  308. }
  309.