tclcmdmz.c

CMX990 demonstration board (DE9901)

/* 
 * tclCmdMZ.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	M to Z.  It contains only commands in the generic core (i.e.
 *	those that don't depend much upon UNIX facilities).
 *
 * Copyright 1987-1991 Regents of the University of California
 * Permission to use, copy, modify, and distribute this
 * software and its documentation for any purpose and without
 * fee is hereby granted, provided that the above copyright
 * notice appear in all copies.  The University of California
 * makes no representations about the suitability of this
 * software for any purpose.  It is provided "as is" without
 * express or implied warranty.
 *
 * $Id: tclCmdMZ.c,v 1.1.1.1 2001/04/29 20:34:35 karll Exp $
 */

#include "tclInt.h"

/*
 * Structure used to hold information about variable traces:
 */

typedef struct {
  int flags;			/* Operations for which Tcl command is
				 * to be invoked. */
  int length;			/* Number of non-NULL chars. in command. */
  char command[4];		/* Space for Tcl command to invoke.  Actual
				 * size will be as large as necessary to
				 * hold command.  This field must be the
				 * last in the structure, so that it can
				 * be larger than 4 bytes. */
} TraceVarInfo;

/*
 * Forward declarations for procedures defined in this file:
 */

static char *		TraceVarProc _ANSI_ARGS_((ClientData clientData,
                                                  Tcl_Interp *interp, char *name1, char *name2,
                                                  int flags));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegexpCmd --
 *
 *	This procedure is invoked to process the "regexp" 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_RegexpCmd(dummy, interp, argc, argv)
  ClientData dummy;			/* Not used. */
Tcl_Interp *interp;			/* Current interpreter. */
int argc;				/* Number of arguments. */
char **argv;			/* Argument strings. */
{
  int noCase = 0;
  int indices = 0;
  regexp *regexpPtr;
  char **argPtr, *string;
  int match, i;

  if (argc < 3) {
  wrongNumArgs:
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " ?-nocase? exp string ?matchVar? ?subMatchVar ",
                     "subMatchVar ...?\"", (char *) NULL);
    return TCL_ERROR;
  }
  argPtr = argv+1;
  argc--;
  while ((argc > 0) && (argPtr[0][0] == '-')) {
    if (strcmp(argPtr[0], "-indices") == 0) {
      argPtr++;
      argc--;
      indices = 1;
    } else if (strcmp(argPtr[0], "-nocase") == 0) {
      argPtr++;
      argc--;
      noCase = 1;
    } else {
      break;
    }
  }
  if (argc < 2) {
    goto wrongNumArgs;
  }
  regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  if (regexpPtr == NULL) {
    return TCL_ERROR;
  }

  /*
   * Convert the string to lower case, if desired, and perform
   * the match.
   */

  if (noCase) {
    register char *dst, *src;

    string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
    for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
      if (isupper(*src)) {
        *dst = tolower(*src);
      } else {
        *dst = *src;
      }
    }
    *dst = 0;
  } else {
    string = argPtr[1];
  }
  tclRegexpError = NULL;
  match = regexec(regexpPtr, string);
  if (string != argPtr[1]) {
    ckfree(string);
  }
  if (tclRegexpError != NULL) {
    Tcl_AppendResult(interp, "error while matching pattern: ",
                     tclRegexpError, (char *) NULL);
    return TCL_ERROR;
  }
  if (!match) {
    interp->result = "0";
    return TCL_OK;
  }

  /*
   * If additional variable names have been specified, return
   * index information in those variables.
   */

  argc -= 2;
  if (argc > NSUBEXP) {
    interp->result = "too many substring variables";
    return TCL_ERROR;
  }
  for (i = 0; i < argc; i++) {
    char *result, info[50];

    if (regexpPtr->startp[i] == NULL) {
      if (indices) {
        result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
      } else {
        result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
      }
    } else {
      if (indices) {
        sprintf(info, "%d %d", (int)(regexpPtr->startp[i] - string),
                (int)(regexpPtr->endp[i] - string - 1));
        result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
      } else {
        char savedChar, *first, *last;

        first = argPtr[1] + (regexpPtr->startp[i] - string);
        last = argPtr[1] + (regexpPtr->endp[i] - string);
        savedChar = *last;
        *last = 0;
        result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
        *last = savedChar;
      }
    }
    if (result == NULL) {
      Tcl_AppendResult(interp, "couldn't set variable \"",
                       argPtr[i+2], "\"", (char *) NULL);
      return TCL_ERROR;
    }
  }
  interp->result = "1";
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegsubCmd --
 *
 *	This procedure is invoked to process the "regsub" 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_RegsubCmd(dummy, interp, argc, argv)
  ClientData dummy;			/* Not used. */
Tcl_Interp *interp;			/* Current interpreter. */
int argc;				/* Number of arguments. */
char **argv;			/* Argument strings. */
{
  int noCase = 0, all = 0;
  regexp *regexpPtr;
  char *string, *p, *firstChar, *newValue, **argPtr;
  int match, result, flags;
  register char *src, c;

  if (argc < 5) {
  wrongNumArgs:
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);
    return TCL_ERROR;
  }
  argPtr = argv+1;
  argc--;
  while (argPtr[0][0] == '-') {
    if (strcmp(argPtr[0], "-nocase") == 0) {
      argPtr++;
      argc--;
      noCase = 1;
    } else if (strcmp(argPtr[0], "-all") == 0) {
      argPtr++;
      argc--;
      all = 1;
    } else {
      break;
    }
  }
  if (argc != 4) {
    goto wrongNumArgs;
  }
  regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  if (regexpPtr == NULL) {
    return TCL_ERROR;
  }

  /*
   * Convert the string to lower case, if desired.
   */

  if (noCase) {
    register char *dst;

    string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
    for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
      if (isupper(*src)) {
        *dst = tolower(*src);
      } else {
        *dst = *src;
      }
    }
    *dst = 0;
  } else {
    string = argPtr[1];
  }

  /*
   * The following loop is to handle multiple matches within the
   * same source string;  each iteration handles one match and its
   * corresponding substitution.  If "-all" hasn't been specified
   * then the loop body only gets executed once.
   */

  flags = 0;
  for (p = string; *p != 0; ) {
    tclRegexpError = NULL;
    match = regexec(regexpPtr, p);
    if (tclRegexpError != NULL) {
      Tcl_AppendResult(interp, "error while matching pattern: ",
                       tclRegexpError, (char *) NULL);
      result = TCL_ERROR;
      goto done;
    }
    if (!match) {
      break;
    }

    /*
     * Copy the portion of the source string before the match to the
     * result variable.
     */
    
    src = argPtr[1] + (regexpPtr->startp[0] - string);
    c = *src;
    *src = 0;
    newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
                          flags);
    *src = c;
    flags = TCL_APPEND_VALUE;
    if (newValue == NULL) {
    cantSet:
      Tcl_AppendResult(interp, "couldn't set variable \"",
                       argPtr[3], "\"", (char *) NULL);
      result = TCL_ERROR;
      goto done;
    }
    
    /*
     * Append the subSpec argument to the variable, making appropriate
     * substitutions.  This code is a bit hairy because of the backslash
     * conventions and because the code saves up ranges of characters in
     * subSpec to reduce the number of calls to Tcl_SetVar.
     */
    
    for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
      int index;
    
      if (c == '&') {
        index = 0;
      } else if (c == '\\') {
        c = src[1];
        if ((c >= '0') && (c <= '9')) {
          index = c - '0';
        } else if ((c == '\\') || (c == '&')) {
          *src = c;
          src[1] = 0;
          newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
                                TCL_APPEND_VALUE);
          *src = '\\';
          src[1] = c;
          if (newValue == NULL) {
            goto cantSet;
          }
          firstChar = src+2;
          src++;
          continue;
        } else {
          continue;
        }
      } else {
        continue;
      }
      if (firstChar != src) {
        c = *src;
        *src = 0;
        newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
                              TCL_APPEND_VALUE);
        *src = c;
        if (newValue == NULL) {
          goto cantSet;
        }
      }
      if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
          && (regexpPtr->endp[index] != NULL)) {
        char *first, *last, saved;
    
        first = argPtr[1] + (regexpPtr->startp[index] - string);
        last = argPtr[1] + (regexpPtr->endp[index] - string);
        saved = *last;
        *last = 0;
        newValue = Tcl_SetVar(interp, argPtr[3], first,
                              TCL_APPEND_VALUE);
        *last = saved;
        if (newValue == NULL) {
          goto cantSet;
        }
      }
      if (*src == '\\') {
        src++;
      }
      firstChar = src+1;
    }
    if (firstChar != src) {
      if (Tcl_SetVar(interp, argPtr[3], firstChar,
                     TCL_APPEND_VALUE) == NULL) {
        goto cantSet;
      }
    }
    p = regexpPtr->endp[0];
    if (!all) {
      break;
    }
  }

  /*
   * If there were no matches at all, then return a "0" result.
   */

  if (p == string) {
    interp->result = "0";
    result = TCL_OK;
    goto done;
  }

  /*
   * Copy the portion of the source string after the last match to the
   * result variable.
   */

  if (*p != 0) {
    if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {
      goto cantSet;
    }
  }
  interp->result = "1";
  result = TCL_OK;

 done:
  if (string != argPtr[1]) {
    ckfree(string);
  }
  return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RenameCmd --
 *
 *	This procedure is invoked to process the "rename" 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_RenameCmd(dummy, interp, argc, argv)
  ClientData dummy;			/* Not used. */
Tcl_Interp *interp;			/* Current interpreter. */
int argc;				/* Number of arguments. */
char **argv;			/* Argument strings. */
{
  register Command *cmdPtr;
  Interp *iPtr = (Interp *) interp;
  Tcl_HashEntry *hPtr;
  int new;

  if (argc != 3) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                     " oldName newName\"", (char *) NULL);
    return TCL_ERROR;
  }
  if (argv[2][0] == '\0') {
    if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
      Tcl_AppendResult(interp, "can't delete \"", argv[1],
                       "\": command doesn't exist", (char *) NULL);
      return TCL_ERROR;
    }
    return TCL_OK;
  }
  hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
  if (hPtr != NULL) {
    Tcl_AppendResult(interp, "can't rename to \"", argv[2],
                     "\": command already exists", (char *) NULL);
    return TCL_ERROR;
  }
  hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
  if (hPtr == NULL) {
    Tcl_AppendResult(interp, "can't rename \"", argv[1],
                     "\":  command doesn't exist", (char *) NULL);
    return TCL_ERROR;
  }
  cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  Tcl_DeleteHashEntry(hPtr);
  hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
  Tcl_SetHashValue(hPtr, cmdPtr);
  return TCL_OK;
}

/*