tclcmdmz.c

CMX990 demonstration board (DE9901)

    int first, last, stringLength;

    if (argc != 5) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " range string first last\"", (char *) NULL);
      return TCL_ERROR;
    }
    stringLength = strlen(argv[2]);
    if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
      return TCL_ERROR;
    }
    if ((*argv[4] == 'e')
        && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
      last = stringLength-1;
    } else {
      if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
        Tcl_ResetResult(interp);
        Tcl_AppendResult(interp,
                         "expected integer or \"end\" but got \"",
                         argv[4], "\"", (char *) NULL);
        return TCL_ERROR;
      }
    }
    if (first < 0) {
      first = 0;
    }
    if (last >= stringLength) {
      last = stringLength-1;
    }
    if (last >= first) {
      char saved, *p;

      p = argv[2] + last + 1;
      saved = *p;
      *p = 0;
      Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
      *p = saved;
    }
    return TCL_OK;
  } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
             && (length >= 3)) {
    register char *p;

    if (argc != 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " tolower string\"", (char *) NULL);
      return TCL_ERROR;
    }
    Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
    for (p = interp->result; *p != 0; p++) {
      if (isupper(*p)) {
        *p = tolower(*p);
      }
    }
    return TCL_OK;
  } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
             && (length >= 3)) {
    register char *p;

    if (argc != 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " toupper string\"", (char *) NULL);
      return TCL_ERROR;
    }
    Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
    for (p = interp->result; *p != 0; p++) {
      if (islower(*p)) {
        *p = toupper(*p);
      }
    }
    return TCL_OK;
  } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
             && (length == 4)) {
    char *trimChars;
    register char *p, *checkPtr;

    left = right = 1;

  trim:
    if (argc == 4) {
      trimChars = argv[3];
    } else if (argc == 3) {
      trimChars = " \t\n\r";
    } else {
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                       " ", argv[1], " string ?chars?\"", (char *) NULL);
      return TCL_ERROR;
    }
    p = argv[2];
    if (left) {
      for (c = *p; c != 0; p++, c = *p) {
        for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
          if (*checkPtr == 0) {
            goto doneLeft;
          }
        }
      }
    }
  doneLeft:
    Tcl_SetResult(interp, p, TCL_VOLATILE);
    if (right) {
      char *donePtr;

      p = interp->result + strlen(interp->result) - 1;
      donePtr = &interp->result[-1];
      for (c = *p; p != donePtr; p--, c = *p) {
        for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
          if (*checkPtr == 0) {
            goto doneRight;
          }
        }
      }
    doneRight:
      p[1] = 0;
    }
    return TCL_OK;
  } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
             && (length > 4)) {
    left = 1;
    argv[1] = "trimleft";
    goto trim;
  } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
             && (length > 4)) {
    right = 1;
    argv[1] = "trimright";
    goto trim;
  } else {
    Tcl_AppendResult(interp, "bad option \"", argv[1],
                     "\": should be compare, first, index, last, length, match, ",
                     "range, tolower, toupper, trim, trimleft, or trimright",
                     (char *) NULL);
    return TCL_ERROR;
  }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceCmd --
 *
 *	This procedure is invoked to process the "trace" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

/* ARGSUSED */
int
Tcl_TraceCmd(dummy, interp, argc, argv)
  ClientData dummy;			/* Not used. */
Tcl_Interp *interp;			/* Current interpreter. */
int argc;				/* Number of arguments. */
char **argv;			/* Argument strings. */
{
  char c;
  int length;

  if (argc < 2) {
    Tcl_AppendResult(interp, "too few args: should be \"",
                     argv[0], " option [arg arg ...]\"", (char *) NULL);
    return TCL_ERROR;
  }
  c = argv[1][1];
  length = strlen(argv[1]);
  if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
      && (length >= 2)) {
    char *p;
    int flags, length;
    TraceVarInfo *tvarPtr;

    if (argc != 5) {
      Tcl_AppendResult(interp, "wrong # args: should be \"",
                       argv[0], " variable name ops command\"", (char *) NULL);
      return TCL_ERROR;
    }

    flags = 0;
    for (p = argv[3] ; *p != 0; p++) {
      if (*p == 'r') {
        flags |= TCL_TRACE_READS;
      } else if (*p == 'w') {
        flags |= TCL_TRACE_WRITES;
      } else if (*p == 'u') {
        flags |= TCL_TRACE_UNSETS;
      } else {
        goto badOps;
      }
    }
    if (flags == 0) {
      goto badOps;
    }

    length = strlen(argv[4]);
    tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
                                       (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
    tvarPtr->flags = flags;
    tvarPtr->length = length;
    flags |= TCL_TRACE_UNSETS;
    strcpy(tvarPtr->command, argv[4]);
    if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
                     (ClientData) tvarPtr) != TCL_OK) {
      ckfree((char *) tvarPtr);
      return TCL_ERROR;
    }
  } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
                            && (length >= 2)) == 0) {
    char *p;
    int flags, length;
    TraceVarInfo *tvarPtr;
    ClientData clientData;

    if (argc != 5) {
      Tcl_AppendResult(interp, "wrong # args: should be \"",
                       argv[0], " vdelete name ops command\"", (char *) NULL);
      return TCL_ERROR;
    }

    flags = 0;
    for (p = argv[3] ; *p != 0; p++) {
      if (*p == 'r') {
        flags |= TCL_TRACE_READS;
      } else if (*p == 'w') {
        flags |= TCL_TRACE_WRITES;
      } else if (*p == 'u') {
        flags |= TCL_TRACE_UNSETS;
      } else {
        goto badOps;
      }
    }
    if (flags == 0) {
      goto badOps;
    }

    /*
     * Search through all of our traces on this variable to
     * see if there's one with the given command.  If so, then
     * delete the first one that matches.
     */

    length = strlen(argv[4]);
    clientData = 0;
    while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
                                          TraceVarProc, clientData)) != 0) {
      tvarPtr = (TraceVarInfo *) clientData;
      if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
          && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
        Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
                       TraceVarProc, clientData);
        ckfree((char *) tvarPtr);
        break;
      }
    }
  } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
             && (length >= 2)) {
    ClientData clientData;
    char ops[4], *p;
    char *prefix = "{";

    if (argc != 3) {
      Tcl_AppendResult(interp, "wrong # args: should be \"",
                       argv[0], " vinfo name\"", (char *) NULL);
      return TCL_ERROR;
    }
    clientData = 0;
    while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
                                          TraceVarProc, clientData)) != 0) {
      TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
      p = ops;
      if (tvarPtr->flags & TCL_TRACE_READS) {
        *p = 'r';
        p++;
      }
      if (tvarPtr->flags & TCL_TRACE_WRITES) {
        *p = 'w';
        p++;
      }
      if (tvarPtr->flags & TCL_TRACE_UNSETS) {
        *p = 'u';
        p++;
      }
      *p = '\0';
      Tcl_AppendResult(interp, prefix, (char *) NULL);
      Tcl_AppendElement(interp, ops, 1);
      Tcl_AppendElement(interp, tvarPtr->command, 0);
      Tcl_AppendResult(interp, "}", (char *) NULL);
      prefix = " {";
    }
  } else {
    Tcl_AppendResult(interp, "bad option \"", argv[1],
                     "\": should be variable, vdelete, or vinfo",
                     (char *) NULL);
    return TCL_ERROR;
  }
  return TCL_OK;

 badOps:
  Tcl_AppendResult(interp, "bad operations \"", argv[3],
                   "\": should be one or more of rwu", (char *) NULL);
  return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceVarProc --
 *
 *	This procedure is called to handle variable accesses that have
 *	been traced using the "trace" command.
 *
 * Results:
 *	Normally returns NULL.  If the trace command returns an error,
 *	then this procedure returns an error string.
 *
 * Side effects:
 *	Depends on the command associated with the trace.
 *
 *----------------------------------------------------------------------
 */

/* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
  ClientData clientData;	/* Information about the variable trace. */
Tcl_Interp *interp;		/* Interpreter containing variable. */
char *name1;		/* Name of variable or array. */
char *name2;		/* Name of element within array;  NULL means
                         * scalar variable is being referenced. */
int flags;			/* OR-ed bits giving operation and other
				 * information. */
{
  TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  char *result;
  int code, cmdLength, flags1, flags2;
  Interp dummy;
#define STATIC_SIZE 199
  char staticSpace[STATIC_SIZE+1];
  char *cmdPtr, *p;

  result = NULL;
  if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {

    /*
     * Generate a command to execute by appending list elements
     * for the two variable names and the operation.  The five
     * extra characters are for three space, the opcode character,
     * and the terminating null.
     */

    if (name2 == NULL) {
      name2 = "";
    }
    cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) +
      Tcl_ScanElement(name2, &flags2) + 5;
    if (cmdLength < STATIC_SIZE) {
      cmdPtr = staticSpace;
    } else {
      cmdPtr = (char *) ckalloc((unsigned) cmdLength);
    }
    p = cmdPtr;
    strcpy(p, tvarPtr->command);
    p += tvarPtr->length;
    *p = ' ';
    p++;
    p += Tcl_ConvertElement(name1, p, flags1);
    *p = ' ';
    p++;
    p += Tcl_ConvertElement(name2, p, flags2);
    *p = ' ';
    if (flags & TCL_TRACE_READS) {
      p[1] = 'r';
    } else if (flags & TCL_TRACE_WRITES) {
      p[1] = 'w';
    } else if (flags & TCL_TRACE_UNSETS) {
      p[1] = 'u';
    }
    p[2] = '\0';

    /*
     * Execute the command.  Be careful to save and restore the
     * result from the interpreter used for the command.
     */

    if (interp->freeProc == 0) {
      dummy.freeProc = (Tcl_FreeProc *) 0;
      dummy.result = "";
      Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
    } else {
      dummy.freeProc = interp->freeProc;
      dummy.result = interp->result;
    }
    code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL);
    if (cmdPtr != staticSpace) {
      ckfree(cmdPtr);
    }
    if (code != TCL_OK) {
      result = "access disallowed by trace command";
      Tcl_ResetResult(interp);		/* Must clear error state. */
    }
    Tcl_FreeResult(interp);
    interp->result = dummy.result;
    interp->freeProc = dummy.freeProc;
  }
  if (flags & TCL_TRACE_DESTROYED) {
    ckfree((char *) tvarPtr);
  }
  return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WhileCmd --
 *
 *	This procedure is invoked to process the "while" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

/* ARGSUSED */
int
Tcl_WhileCmd(dummy, interp, argc, argv)
  ClientData dummy;			/* Not used. */
Tcl_Interp *interp;			/* Current interpreter. */
int argc;				/* Number of arguments. */
char **argv;			/* Argument strings. */
{
  int result, value;

  if (argc != 3) {
    Tcl_AppendResult(interp, "wrong # args: should be \"",
                     argv[0], " test command\"", (char *) NULL);
    return TCL_ERROR;
  }

  while (1) {
    result = Tcl_ExprBoolean(interp, argv[1], &value);
    if (result != TCL_OK) {
      return result;
    }
    if (!value) {
      break;
    }
    result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);
    if (result == TCL_CONTINUE) {
      result = TCL_OK;
    } else if (result != TCL_OK) {
      if (result == TCL_ERROR) {
        char msg[60];
        sprintf(msg, "\n    (\"while\" body line %d)",
                interp->errorLine);
        Tcl_AddErrorInfo(interp, msg);
      }
      break;
    }
  }
  if (result == TCL_BREAK) {
    result = TCL_OK;
  }
  if (result == TCL_OK) {
    Tcl_ResetResult(interp);
  }
  return result;
}