summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdMZ.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdMZ.c')
-rw-r--r--generic/tclCmdMZ.c2186
1 files changed, 2186 insertions, 0 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
new file mode 100644
index 0000000..4dc272f
--- /dev/null
+++ b/generic/tclCmdMZ.c
@@ -0,0 +1,2186 @@
+/*
+ * 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 (c) 1987-1993 The Regents of the University of California.
+ * Copyright (c) 1994-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: @(#) tclCmdMZ.c 1.104 97/10/31 13:06:19
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#include "tclCompile.h"
+
+/*
+ * Structure used to hold information about variable traces:
+ */
+
+typedef struct {
+ int flags; /* Operations for which Tcl command is
+ * to be invoked. */
+ char *errMsg; /* Error message returned from Tcl command,
+ * or NULL. Malloc'ed. */
+ 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_PwdCmd --
+ *
+ * This procedure is invoked to process the "pwd" 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_PwdCmd(dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ char *dirName;
+
+ if (argc != 1) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ dirName = TclGetCwd(interp);
+ if (dirName == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetResult(interp, dirName, TCL_VOLATILE);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ Tcl_RegExp regExpr;
+ char **argPtr, *string, *pattern, *start, *end;
+ int match = 0; /* Initialization needed only to
+ * prevent compiler warning. */
+ int i;
+ Tcl_DString stringDString, patternDString;
+
+ if (argc < 3) {
+ wrongNumArgs:
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " ?switches? 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) {
+ indices = 1;
+ } else if (strcmp(argPtr[0], "-nocase") == 0) {
+ noCase = 1;
+ } else if (strcmp(argPtr[0], "--") == 0) {
+ argPtr++;
+ argc--;
+ break;
+ } else {
+ Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
+ "\": must be -indices, -nocase, or --", (char *) NULL);
+ return TCL_ERROR;
+ }
+ argPtr++;
+ argc--;
+ }
+ if (argc < 2) {
+ goto wrongNumArgs;
+ }
+
+ /*
+ * Convert the string and pattern to lower case, if desired, and
+ * perform the matching operation.
+ */
+
+ if (noCase) {
+ register char *p;
+
+ Tcl_DStringInit(&patternDString);
+ Tcl_DStringAppend(&patternDString, argPtr[0], -1);
+ pattern = Tcl_DStringValue(&patternDString);
+ for (p = pattern; *p != 0; p++) {
+ if (isupper(UCHAR(*p))) {
+ *p = (char)tolower(UCHAR(*p));
+ }
+ }
+ Tcl_DStringInit(&stringDString);
+ Tcl_DStringAppend(&stringDString, argPtr[1], -1);
+ string = Tcl_DStringValue(&stringDString);
+ for (p = string; *p != 0; p++) {
+ if (isupper(UCHAR(*p))) {
+ *p = (char)tolower(UCHAR(*p));
+ }
+ }
+ } else {
+ pattern = argPtr[0];
+ string = argPtr[1];
+ }
+ regExpr = Tcl_RegExpCompile(interp, pattern);
+ if (regExpr != NULL) {
+ match = Tcl_RegExpExec(interp, regExpr, string, string);
+ }
+ if (noCase) {
+ Tcl_DStringFree(&stringDString);
+ Tcl_DStringFree(&patternDString);
+ }
+ if (regExpr == NULL) {
+ return TCL_ERROR;
+ }
+ if (match < 0) {
+ return TCL_ERROR;
+ }
+ if (!match) {
+ Tcl_SetResult(interp, "0", TCL_STATIC);
+ return TCL_OK;
+ }
+
+ /*
+ * If additional variable names have been specified, return
+ * index information in those variables.
+ */
+
+ argc -= 2;
+ for (i = 0; i < argc; i++) {
+ char *result, info[50];
+
+ Tcl_RegExpRange(regExpr, i, &start, &end);
+ if (start == 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)(start - string),
+ (int)(end - string - 1));
+ result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
+ } else {
+ char savedChar, *first, *last;
+
+ first = argPtr[1] + (start - string);
+ last = argPtr[1] + (end - string);
+ if (first == last) { /* don't modify argument */
+ result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
+ } else {
+ 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;
+ }
+ }
+ Tcl_SetResult(interp, "1", TCL_STATIC);
+ 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;
+ Tcl_RegExp regExpr;
+ char *string, *pattern, *p, *firstChar, **argPtr;
+ int match, code, numMatches;
+ char *start, *end, *subStart, *subEnd;
+ register char *src, c;
+ Tcl_DString stringDString, patternDString, resultDString;
+
+ if (argc < 5) {
+ wrongNumArgs:
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " ?switches? exp string subSpec varName\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ argPtr = argv+1;
+ argc--;
+ while (argPtr[0][0] == '-') {
+ if (strcmp(argPtr[0], "-nocase") == 0) {
+ noCase = 1;
+ } else if (strcmp(argPtr[0], "-all") == 0) {
+ all = 1;
+ } else if (strcmp(argPtr[0], "--") == 0) {
+ argPtr++;
+ argc--;
+ break;
+ } else {
+ Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
+ "\": must be -all, -nocase, or --", (char *) NULL);
+ return TCL_ERROR;
+ }
+ argPtr++;
+ argc--;
+ }
+ if (argc != 4) {
+ goto wrongNumArgs;
+ }
+
+ /*
+ * Convert the string and pattern to lower case, if desired.
+ */
+
+ if (noCase) {
+ Tcl_DStringInit(&patternDString);
+ Tcl_DStringAppend(&patternDString, argPtr[0], -1);
+ pattern = Tcl_DStringValue(&patternDString);
+ for (p = pattern; *p != 0; p++) {
+ if (isupper(UCHAR(*p))) {
+ *p = (char)tolower(UCHAR(*p));
+ }
+ }
+ Tcl_DStringInit(&stringDString);
+ Tcl_DStringAppend(&stringDString, argPtr[1], -1);
+ string = Tcl_DStringValue(&stringDString);
+ for (p = string; *p != 0; p++) {
+ if (isupper(UCHAR(*p))) {
+ *p = (char)tolower(UCHAR(*p));
+ }
+ }
+ } else {
+ pattern = argPtr[0];
+ string = argPtr[1];
+ }
+ Tcl_DStringInit(&resultDString);
+ regExpr = Tcl_RegExpCompile(interp, pattern);
+ if (regExpr == NULL) {
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * 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.
+ */
+
+ numMatches = 0;
+ for (p = string; *p != 0; ) {
+ match = Tcl_RegExpExec(interp, regExpr, p, string);
+ if (match < 0) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ if (!match) {
+ break;
+ }
+ numMatches += 1;
+
+ /*
+ * Copy the portion of the source string before the match to the
+ * result variable.
+ */
+
+ Tcl_RegExpRange(regExpr, 0, &start, &end);
+ Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), start - p);
+
+ /*
+ * 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;
+ Tcl_DStringAppend(&resultDString, firstChar, -1);
+ *src = '\\';
+ src[1] = c;
+ firstChar = src+2;
+ src++;
+ continue;
+ } else {
+ continue;
+ }
+ } else {
+ continue;
+ }
+ if (firstChar != src) {
+ c = *src;
+ *src = 0;
+ Tcl_DStringAppend(&resultDString, firstChar, -1);
+ *src = c;
+ }
+ Tcl_RegExpRange(regExpr, index, &subStart, &subEnd);
+ if ((subStart != NULL) && (subEnd != NULL)) {
+ char *first, *last, saved;
+
+ first = argPtr[1] + (subStart - string);
+ last = argPtr[1] + (subEnd - string);
+ saved = *last;
+ *last = 0;
+ Tcl_DStringAppend(&resultDString, first, -1);
+ *last = saved;
+ }
+ if (*src == '\\') {
+ src++;
+ }
+ firstChar = src+1;
+ }
+ if (firstChar != src) {
+ Tcl_DStringAppend(&resultDString, firstChar, -1);
+ }
+ if (end == p) {
+
+ /*
+ * Always consume at least one character of the input string
+ * in order to prevent infinite loops.
+ */
+
+ Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), 1);
+ p = end + 1;
+ } else {
+ p = end;
+ }
+ if (!all) {
+ break;
+ }
+ }
+
+ /*
+ * Copy the portion of the source string after the last match to the
+ * result variable.
+ */
+
+ if ((*p != 0) || (numMatches == 0)) {
+ Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), -1);
+ }
+ if (Tcl_SetVar(interp, argPtr[3], Tcl_DStringValue(&resultDString), 0)
+ == NULL) {
+ Tcl_AppendResult(interp,
+ "couldn't set variable \"", argPtr[3], "\"",
+ (char *) NULL);
+ code = TCL_ERROR;
+ } else {
+ char buf[40];
+
+ TclFormatInt(buf, numMatches);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ code = TCL_OK;
+ }
+
+ done:
+ if (noCase) {
+ Tcl_DStringFree(&stringDString);
+ Tcl_DStringFree(&patternDString);
+ }
+ Tcl_DStringFree(&resultDString);
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RenameObjCmd --
+ *
+ * This procedure is invoked to process the "rename" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_RenameObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Arbitrary value passed to the command. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *oldName, *newName;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
+ return TCL_ERROR;
+ }
+
+ oldName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ newName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ return TclRenameCommand(interp, oldName, newName);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ReturnObjCmd --
+ *
+ * This object-based procedure is invoked to process the "return" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_ReturnObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int optionLen, argLen, code, result;
+
+ if (iPtr->errorInfo != NULL) {
+ ckfree(iPtr->errorInfo);
+ iPtr->errorInfo = NULL;
+ }
+ if (iPtr->errorCode != NULL) {
+ ckfree(iPtr->errorCode);
+ iPtr->errorCode = NULL;
+ }
+ code = TCL_OK;
+
+ /*
+ * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL.
+ */
+
+ for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
+ char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
+ char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
+
+ if (strcmp(option, "-code") == 0) {
+ register int c = arg[0];
+ if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
+ code = TCL_OK;
+ } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
+ code = TCL_ERROR;
+ } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
+ code = TCL_RETURN;
+ } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
+ code = TCL_BREAK;
+ } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
+ code = TCL_CONTINUE;
+ } else {
+ result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
+ &code);
+ if (result != TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad completion code \"",
+ Tcl_GetStringFromObj(objv[1], (int *) NULL),
+ "\": must be ok, error, return, break, ",
+ "continue, or an integer", (char *) NULL);
+ return result;
+ }
+ }
+ } else if (strcmp(option, "-errorinfo") == 0) {
+ iPtr->errorInfo =
+ (char *) ckalloc((unsigned) (strlen(arg) + 1));
+ strcpy(iPtr->errorInfo, arg);
+ } else if (strcmp(option, "-errorcode") == 0) {
+ iPtr->errorCode =
+ (char *) ckalloc((unsigned) (strlen(arg) + 1));
+ strcpy(iPtr->errorCode, arg);
+ } else {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad option \"", option,
+ "\": must be -code, -errorcode, or -errorinfo",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ if (objc == 1) {
+ /*
+ * Set the interpreter's object result. An inline version of
+ * Tcl_SetObjResult.
+ */
+
+ Tcl_SetObjResult(interp, objv[0]);
+ }
+ iPtr->returnCode = code;
+ return TCL_RETURN;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ScanCmd --
+ *
+ * This procedure is invoked to process the "scan" 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_ScanCmd(dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+# define MAX_FIELDS 20
+ typedef struct {
+ char fmt; /* Format for field. */
+ int size; /* How many bytes to allow for
+ * field. */
+ char *location; /* Where field will be stored. */
+ } Field;
+ Field fields[MAX_FIELDS]; /* Info about all the fields in the
+ * format string. */
+ register Field *curField;
+ int numFields = 0; /* Number of fields actually
+ * specified. */
+ int suppress; /* Current field is assignment-
+ * suppressed. */
+ int totalSize = 0; /* Number of bytes needed to store
+ * all results combined. */
+ char *results; /* Where scanned output goes.
+ * Malloced; NULL means not allocated
+ * yet. */
+ int numScanned; /* sscanf's result. */
+ register char *fmt;
+ int i, widthSpecified, length, code;
+ char buf[40];
+
+ /*
+ * The variables below are used to hold a copy of the format
+ * string, so that we can replace format specifiers like "%f"
+ * and "%F" with specifiers like "%lf"
+ */
+
+# define STATIC_SIZE 5
+ char copyBuf[STATIC_SIZE], *fmtCopy;
+ register char *dst;
+
+ if (argc < 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " string format ?varName varName ...?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * This procedure operates in four stages:
+ * 1. Scan the format string, collecting information about each field.
+ * 2. Allocate an array to hold all of the scanned fields.
+ * 3. Call sscanf to do all the dirty work, and have it store the
+ * parsed fields in the array.
+ * 4. Pick off the fields from the array and assign them to variables.
+ */
+
+ code = TCL_OK;
+ results = NULL;
+ length = strlen(argv[2]) * 2 + 1;
+ if (length < STATIC_SIZE) {
+ fmtCopy = copyBuf;
+ } else {
+ fmtCopy = (char *) ckalloc((unsigned) length);
+ }
+ dst = fmtCopy;
+ for (fmt = argv[2]; *fmt != 0; fmt++) {
+ *dst = *fmt;
+ dst++;
+ if (*fmt != '%') {
+ continue;
+ }
+ fmt++;
+ if (*fmt == '%') {
+ *dst = *fmt;
+ dst++;
+ continue;
+ }
+ if (*fmt == '*') {
+ suppress = 1;
+ *dst = *fmt;
+ dst++;
+ fmt++;
+ } else {
+ suppress = 0;
+ }
+ widthSpecified = 0;
+ while (isdigit(UCHAR(*fmt))) {
+ widthSpecified = 1;
+ *dst = *fmt;
+ dst++;
+ fmt++;
+ }
+ if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) {
+ fmt++;
+ }
+ *dst = *fmt;
+ dst++;
+ if (suppress) {
+ continue;
+ }
+ if (numFields == MAX_FIELDS) {
+ Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC);
+ code = TCL_ERROR;
+ goto done;
+ }
+ curField = &fields[numFields];
+ numFields++;
+ switch (*fmt) {
+ case 'd':
+ case 'i':
+ case 'o':
+ case 'x':
+ curField->fmt = 'd';
+ curField->size = sizeof(int);
+ break;
+
+ case 'u':
+ curField->fmt = 'u';
+ curField->size = sizeof(int);
+ break;
+
+ case 's':
+ curField->fmt = 's';
+ curField->size = strlen(argv[1]) + 1;
+ break;
+
+ case 'c':
+ if (widthSpecified) {
+ Tcl_SetResult(interp,
+ "field width may not be specified in %c conversion",
+ TCL_STATIC);
+ code = TCL_ERROR;
+ goto done;
+ }
+ curField->fmt = 'c';
+ curField->size = sizeof(int);
+ break;
+
+ case 'e':
+ case 'f':
+ case 'g':
+ dst[-1] = 'l';
+ dst[0] = 'f';
+ dst++;
+ curField->fmt = 'f';
+ curField->size = sizeof(double);
+ break;
+
+ case '[':
+ curField->fmt = 's';
+ curField->size = strlen(argv[1]) + 1;
+ do {
+ fmt++;
+ if (*fmt == 0) {
+ Tcl_SetResult(interp,
+ "unmatched [ in format string", TCL_STATIC);
+ code = TCL_ERROR;
+ goto done;
+ }
+ *dst = *fmt;
+ dst++;
+ } while (*fmt != ']');
+ break;
+
+ default:
+ {
+ char buf[50];
+
+ sprintf(buf, "bad scan conversion character \"%c\"", *fmt);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ code = TCL_ERROR;
+ goto done;
+ }
+ }
+ curField->size = TCL_ALIGN(curField->size);
+ totalSize += curField->size;
+ }
+ *dst = 0;
+
+ if (numFields != (argc-3)) {
+ Tcl_SetResult(interp,
+ "different numbers of variable names and field specifiers",
+ TCL_STATIC);
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Step 2:
+ */
+
+ results = (char *) ckalloc((unsigned) totalSize);
+ for (i = 0, totalSize = 0, curField = fields;
+ i < numFields; i++, curField++) {
+ curField->location = results + totalSize;
+ totalSize += curField->size;
+ }
+
+ /*
+ * Fill in the remaining fields with NULL; the only purpose of
+ * this is to keep some memory analyzers, like Purify, from
+ * complaining.
+ */
+
+ for ( ; i < MAX_FIELDS; i++, curField++) {
+ curField->location = NULL;
+ }
+
+ /*
+ * Step 3:
+ */
+
+ numScanned = sscanf(argv[1], fmtCopy,
+ fields[0].location, fields[1].location, fields[2].location,
+ fields[3].location, fields[4].location, fields[5].location,
+ fields[6].location, fields[7].location, fields[8].location,
+ fields[9].location, fields[10].location, fields[11].location,
+ fields[12].location, fields[13].location, fields[14].location,
+ fields[15].location, fields[16].location, fields[17].location,
+ fields[18].location, fields[19].location);
+
+ /*
+ * Step 4:
+ */
+
+ if (numScanned < numFields) {
+ numFields = numScanned;
+ }
+ for (i = 0, curField = fields; i < numFields; i++, curField++) {
+ switch (curField->fmt) {
+ char string[TCL_DOUBLE_SPACE];
+
+ case 'd':
+ TclFormatInt(string, *((int *) curField->location));
+ if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
+ storeError:
+ Tcl_AppendResult(interp,
+ "couldn't set variable \"", argv[i+3], "\"",
+ (char *) NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
+ break;
+
+ case 'u':
+ sprintf(string, "%u", *((int *) curField->location));
+ if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
+ goto storeError;
+ }
+ break;
+
+ case 'c':
+ TclFormatInt(string, *((char *) curField->location) & 0xff);
+ if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
+ goto storeError;
+ }
+ break;
+
+ case 's':
+ if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
+ == NULL) {
+ goto storeError;
+ }
+ break;
+
+ case 'f':
+ Tcl_PrintDouble((Tcl_Interp *) NULL,
+ *((double *) curField->location), string);
+ if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
+ goto storeError;
+ }
+ break;
+ }
+ }
+ TclFormatInt(buf, numScanned);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ done:
+ if (results != NULL) {
+ ckfree(results);
+ }
+ if (fmtCopy != copyBuf) {
+ ckfree(fmtCopy);
+ }
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SourceObjCmd --
+ *
+ * This procedure is invoked to process the "source" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_SourceObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *bytes;
+ int result;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "fileName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
+ */
+
+ bytes = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ result = Tcl_EvalFile(interp, bytes);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SplitObjCmd --
+ *
+ * This procedure is invoked to process the "split" 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_SplitObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ register char *p, *p2;
+ char *splitChars, *string, *elementStart;
+ int splitCharLen, stringLen, i, j;
+ Tcl_Obj *listPtr;
+
+ if (objc == 2) {
+ splitChars = " \n\t\r";
+ splitCharLen = 4;
+ } else if (objc == 3) {
+ splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
+ return TCL_ERROR;
+ }
+
+ string = Tcl_GetStringFromObj(objv[1], &stringLen);
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
+ /*
+ * Handle the special case of splitting on every character.
+ */
+
+ if (splitCharLen == 0) {
+ for (i = 0, p = string; i < stringLen; i++, p++) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(p, 1));
+ }
+ } else {
+ /*
+ * Normal case: split on any of a given set of characters.
+ * Discard instances of the split characters.
+ */
+
+ for (i = 0, p = elementStart = string; i < stringLen; i++, p++) {
+ for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) {
+ if (*p2 == *p) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(elementStart, (p-elementStart)));
+ elementStart = p+1;
+ break;
+ }
+ }
+ }
+ if (p != string) {
+ int remainingChars = stringLen - (elementStart-string);
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(elementStart, remainingChars));
+ }
+ }
+
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_StringObjCmd --
+ *
+ * This procedure is invoked to process the "string" 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_StringObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int index, left, right;
+ Tcl_Obj *resultPtr;
+ char *string1, *string2;
+ int length1, length2;
+ static char *options[] = {
+ "compare", "first", "index", "last",
+ "length", "match", "range", "tolower",
+ "toupper", "trim", "trimleft", "trimright",
+ "wordend", "wordstart", NULL
+ };
+ enum options {
+ STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST,
+ STR_LENGTH, STR_MATCH, STR_RANGE, STR_TOLOWER,
+ STR_TOUPPER, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
+ STR_WORDEND, STR_WORDSTART
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ resultPtr = Tcl_GetObjResult(interp);
+ switch ((enum options) index) {
+ case STR_COMPARE: {
+ int match, length;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+
+ length = (length1 < length2) ? length1 : length2;
+ match = memcmp(string1, string2, (unsigned) length);
+ if (match == 0) {
+ match = length1 - length2;
+ }
+ Tcl_SetIntObj(resultPtr, (match > 0) ? 1 : (match < 0) ? -1 : 0);
+ break;
+ }
+ case STR_FIRST: {
+ register char *p, *end;
+ int match;
+
+ if (objc != 4) {
+ badFirstLastArgs:
+ Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
+ return TCL_ERROR;
+ }
+
+ match = -1;
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ if (length1 > 0) {
+ end = string2 + length2 - length1 + 1;
+ for (p = string2; p < end; p++) {
+ /*
+ * Scan forward to find the first character.
+ */
+
+ p = memchr(p, *string1, (unsigned) (end - p));
+ if (p == NULL) {
+ break;
+ }
+ if (memcmp(string1, p, (unsigned) length1) == 0) {
+ match = p - string2;
+ break;
+ }
+ }
+ }
+ Tcl_SetIntObj(resultPtr, match);
+ break;
+ }
+ case STR_INDEX: {
+ int index;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if ((index >= 0) && (index < length1)) {
+ Tcl_SetStringObj(resultPtr, string1 + index, 1);
+ }
+ break;
+ }
+ case STR_LAST: {
+ register char *p;
+ int match;
+
+ if (objc != 4) {
+ goto badFirstLastArgs;
+ }
+
+ match = -1;
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ if (length1 > 0) {
+ for (p = string2 + length2 - length1; p >= string2; p--) {
+ /*
+ * Scan backwards to find the first character.
+ */
+
+ while ((p != string2) && (*p != *string1)) {
+ p--;
+ }
+ if (memcmp(string1, p, (unsigned) length1) == 0) {
+ match = p - string2;
+ break;
+ }
+ }
+ }
+ Tcl_SetIntObj(resultPtr, match);
+ break;
+ }
+ case STR_LENGTH: {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
+ return TCL_ERROR;
+ }
+
+ (void) Tcl_GetStringFromObj(objv[2], &length1);
+ Tcl_SetIntObj(resultPtr, length1);
+ break;
+ }
+ case STR_MATCH: {
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "pattern string");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ Tcl_SetBooleanObj(resultPtr, Tcl_StringMatch(string2, string1));
+ break;
+ }
+ case STR_RANGE: {
+ int first, last;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string first last");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ if (TclGetIntForIndex(interp, objv[3], length1 - 1,
+ &first) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (TclGetIntForIndex(interp, objv[4], length1 - 1,
+ &last) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (first < 0) {
+ first = 0;
+ }
+ if (last >= length1 - 1) {
+ last = length1 - 1;
+ }
+ if (last >= first) {
+ Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1);
+ }
+ break;
+ }
+ case STR_TOLOWER: {
+ register char *p, *end;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+
+ /*
+ * Since I know resultPtr is not a shared object, I can reach
+ * in and diddle the bytes in its string rep to convert them in
+ * place to lower case.
+ */
+
+ Tcl_SetStringObj(resultPtr, string1, length1);
+ string1 = Tcl_GetStringFromObj(resultPtr, &length1);
+ end = string1 + length1;
+ for (p = string1; p < end; p++) {
+ if (isupper(UCHAR(*p))) {
+ *p = (char) tolower(UCHAR(*p));
+ }
+ }
+ break;
+ }
+ case STR_TOUPPER: {
+ register char *p, *end;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+
+ /*
+ * Since I know resultPtr is not a shared object, I can reach
+ * in and diddle the bytes in its string rep to convert them in
+ * place to upper case.
+ */
+
+ Tcl_SetStringObj(resultPtr, string1, length1);
+ string1 = Tcl_GetStringFromObj(resultPtr, &length1);
+ end = string1 + length1;
+ for (p = string1; p < end; p++) {
+ if (islower(UCHAR(*p))) {
+ *p = (char) toupper(UCHAR(*p));
+ }
+ }
+ break;
+ }
+ case STR_TRIM: {
+ char ch;
+ register char *p, *end;
+ char *check, *checkEnd;
+
+ left = 1;
+ right = 1;
+
+ trim:
+ if (objc == 4) {
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ } else if (objc == 3) {
+ string2 = " \t\n\r";
+ length2 = strlen(string2);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
+ return TCL_ERROR;
+ }
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ checkEnd = string2 + length2;
+
+ if (left) {
+ end = string1 + length1;
+ for (p = string1; p < end; p++) {
+ ch = *p;
+ for (check = string2; ; check++) {
+ if (check >= checkEnd) {
+ p = end;
+ break;
+ }
+ if (ch == *check) {
+ length1--;
+ string1++;
+ break;
+ }
+ }
+ }
+ }
+ if (right) {
+ end = string1;
+ for (p = string1 + length1; p > end; ) {
+ p--;
+ ch = *p;
+ for (check = string2; ; check++) {
+ if (check >= checkEnd) {
+ p = end;
+ break;
+ }
+ if (ch == *check) {
+ length1--;
+ break;
+ }
+ }
+ }
+ }
+ Tcl_SetStringObj(resultPtr, string1, length1);
+ break;
+ }
+ case STR_TRIMLEFT: {
+ left = 1;
+ right = 0;
+ goto trim;
+ }
+ case STR_TRIMRIGHT: {
+ left = 0;
+ right = 1;
+ goto trim;
+ }
+ case STR_WORDEND: {
+ int cur, c;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string index");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index < 0) {
+ index = 0;
+ }
+ cur = length1;
+ if (index < length1) {
+ for (cur = index; cur < length1; cur++) {
+ c = UCHAR(string1[cur]);
+ if (!isalnum(c) && (c != '_')) {
+ break;
+ }
+ }
+ if (cur == index) {
+ cur = index + 1;
+ }
+ }
+ Tcl_SetIntObj(resultPtr, cur);
+ break;
+ }
+ case STR_WORDSTART: {
+ int cur, c;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string index");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index >= length1) {
+ index = length1 - 1;
+ }
+ cur = 0;
+ if (index > 0) {
+ for (cur = index; cur >= 0; cur--) {
+ c = UCHAR(string1[cur]);
+ if (!isalnum(c) && (c != '_')) {
+ break;
+ }
+ }
+ if (cur != index) {
+ cur += 1;
+ }
+ }
+ Tcl_SetIntObj(resultPtr, cur);
+ break;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SubstCmd --
+ *
+ * This procedure is invoked to process the "subst" Tcl command.
+ * See the user documentation for details on what it does. This
+ * command is an almost direct copy of an implementation by
+ * Andrew Payne.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_SubstCmd(dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_DString result;
+ char *p, *old, *value;
+ int code, count, doVars, doCmds, doBackslashes, i;
+ size_t length;
+ char c;
+
+ /*
+ * Parse command-line options.
+ */
+
+ doVars = doCmds = doBackslashes = 1;
+ for (i = 1; i < (argc-1); i++) {
+ p = argv[i];
+ if (*p != '-') {
+ break;
+ }
+ length = strlen(p);
+ if (length < 4) {
+ badSwitch:
+ Tcl_AppendResult(interp, "bad switch \"", p,
+ "\": must be -nobackslashes, -nocommands, ",
+ "or -novariables", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) {
+ doBackslashes = 0;
+ } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) {
+ doCmds = 0;
+ } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) {
+ doVars = 0;
+ } else {
+ goto badSwitch;
+ }
+ }
+ if (i != (argc-1)) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " ?-nobackslashes? ?-nocommands? ?-novariables? string\"",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Scan through the string one character at a time, performing
+ * command, variable, and backslash substitutions.
+ */
+
+ Tcl_DStringInit(&result);
+ old = p = argv[i];
+ while (*p != 0) {
+ switch (*p) {
+ case '\\':
+ if (doBackslashes) {
+ if (p != old) {
+ Tcl_DStringAppend(&result, old, p-old);
+ }
+ c = Tcl_Backslash(p, &count);
+ Tcl_DStringAppend(&result, &c, 1);
+ p += count;
+ old = p;
+ } else {
+ p++;
+ }
+ break;
+
+ case '$':
+ if (doVars) {
+ if (p != old) {
+ Tcl_DStringAppend(&result, old, p-old);
+ }
+ value = Tcl_ParseVar(interp, p, &p);
+ if (value == NULL) {
+ Tcl_DStringFree(&result);
+ return TCL_ERROR;
+ }
+ Tcl_DStringAppend(&result, value, -1);
+ old = p;
+ } else {
+ p++;
+ }
+ break;
+
+ case '[':
+ if (doCmds) {
+ if (p != old) {
+ Tcl_DStringAppend(&result, old, p-old);
+ }
+ iPtr->evalFlags = TCL_BRACKET_TERM;
+ code = Tcl_Eval(interp, p+1);
+ if (code == TCL_ERROR) {
+ Tcl_DStringFree(&result);
+ return code;
+ }
+ old = p = (p+1 + iPtr->termOffset+1);
+ Tcl_DStringAppend(&result, iPtr->result, -1);
+ Tcl_ResetResult(interp);
+ } else {
+ p++;
+ }
+ break;
+
+ default:
+ p++;
+ break;
+ }
+ }
+ if (p != old) {
+ Tcl_DStringAppend(&result, old, p-old);
+ }
+ Tcl_DStringResult(interp, &result);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SwitchObjCmd --
+ *
+ * This object-based procedure is invoked to process the "switch" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_SwitchObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+#define EXACT 0
+#define GLOB 1
+#define REGEXP 2
+ int switchObjc, index;
+ Tcl_Obj *CONST *switchObjv;
+ Tcl_Obj *patternObj, *bodyObj;
+ char *string, *pattern, *body;
+ int splitObjs, length, patternLen, i, code, mode, matched, bodyIdx;
+ static char *switches[] =
+ {"-exact", "-glob", "-regexp", "--", (char *) NULL};
+
+ switchObjc = objc-1;
+ switchObjv = objv+1;
+ mode = EXACT;
+
+ while (switchObjc > 0) {
+ string = Tcl_GetStringFromObj(switchObjv[0], &length);
+ if (*string != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches,
+ "option", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case 0: /* -exact */
+ mode = EXACT;
+ break;
+ case 1: /* -glob */
+ mode = GLOB;
+ break;
+ case 2: /* -regexp */
+ mode = REGEXP;
+ break;
+ case 3: /* -- */
+ switchObjc--;
+ switchObjv++;
+ goto doneWithSwitches;
+ }
+ switchObjc--;
+ switchObjv++;
+ }
+
+ doneWithSwitches:
+ if (switchObjc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?switches? string pattern body ... ?default body?");
+ return TCL_ERROR;
+ }
+
+ string = Tcl_GetStringFromObj(switchObjv[0], &length);
+ switchObjc--;
+ switchObjv++;
+
+ /*
+ * If all of the pattern/command pairs are lumped into a single
+ * argument, split them out again.
+ */
+
+ splitObjs = 0;
+ if (switchObjc == 1) {
+ code = Tcl_ListObjLength(interp, switchObjv[0], &switchObjc);
+ if (code != TCL_OK) {
+ return code;
+ }
+ splitObjs = 1;
+ }
+
+ for (i = 0; i < switchObjc; i += 2) {
+ if (i == (switchObjc-1)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra switch pattern with no body", -1);
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * See if the pattern matches the string.
+ */
+
+ if (splitObjs) {
+ code = Tcl_ListObjIndex(interp, switchObjv[0], i, &patternObj);
+ if (code != TCL_OK) {
+ return code;
+ }
+ pattern = Tcl_GetStringFromObj(patternObj, &patternLen);
+ } else {
+ pattern = Tcl_GetStringFromObj(switchObjv[i], &patternLen);
+ }
+
+ matched = 0;
+ if ((*pattern == 'd') && (i == switchObjc-2)
+ && (strcmp(pattern, "default") == 0)) {
+ matched = 1;
+ } else {
+ /*
+ * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
+ */
+ switch (mode) {
+ case EXACT:
+ matched = (strcmp(string, pattern) == 0);
+ break;
+ case GLOB:
+ matched = Tcl_StringMatch(string, pattern);
+ break;
+ case REGEXP:
+ matched = Tcl_RegExpMatch(interp, string, pattern);
+ if (matched < 0) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ break;
+ }
+ }
+ if (!matched) {
+ continue;
+ }
+
+ /*
+ * We've got a match. Find a body to execute, skipping bodies
+ * that are "-".
+ */
+
+ for (bodyIdx = i+1; ; bodyIdx += 2) {
+ if (bodyIdx >= switchObjc) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "no body specified for pattern \"", pattern,
+ "\"", (char *) NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ if (splitObjs) {
+ code = Tcl_ListObjIndex(interp, switchObjv[0], bodyIdx,
+ &bodyObj);
+ if (code != TCL_OK) {
+ return code;
+ }
+ } else {
+ bodyObj = switchObjv[bodyIdx];
+ }
+ /*
+ * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
+ */
+ body = Tcl_GetStringFromObj(bodyObj, &length);
+ if ((length != 1) || (body[0] != '-')) {
+ break;
+ }
+ }
+ code = Tcl_EvalObj(interp, bodyObj);
+ if (code == TCL_ERROR) {
+ char msg[100];
+ sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ }
+ goto done;
+ }
+
+ /*
+ * Nothing matched: return nothing.
+ */
+
+ code = TCL_OK;
+
+ done:
+ return code;
+#undef EXACT
+#undef GLOB
+#undef REGEXP
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_TimeObjCmd --
+ *
+ * This object-based procedure is invoked to process the "time" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_TimeObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ register Tcl_Obj *objPtr;
+ register int i, result;
+ int count;
+ double totalMicroSec;
+ Tcl_Time start, stop;
+ char buf[100];
+
+ if (objc == 2) {
+ count = 1;
+ } else if (objc == 3) {
+ result = Tcl_GetIntFromObj(interp, objv[2], &count);
+ if (result != TCL_OK) {
+ return result;
+ }
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
+ return TCL_ERROR;
+ }
+
+ objPtr = objv[1];
+ i = count;
+ TclpGetTime(&start);
+ while (i-- > 0) {
+ result = Tcl_EvalObj(interp, objPtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+ TclpGetTime(&stop);
+
+ totalMicroSec =
+ (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
+ sprintf(buf, "%.0f microseconds per iteration",
+ ((count <= 0) ? 0 : totalMicroSec/count));
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ int c;
+ size_t 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->errMsg = NULL;
+ 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,
+ (size_t) length) == 0)) {
+ Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
+ TraceVarProc, clientData);
+ if (tvarPtr->errMsg != NULL) {
+ ckfree(tvarPtr->errMsg);
+ }
+ 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);
+ Tcl_AppendElement(interp, tvarPtr->command);
+ 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. */
+{
+ Interp *iPtr = (Interp *) interp;
+ TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+ char *result;
+ int code;
+ Interp dummy;
+ Tcl_DString cmd;
+ Tcl_Obj *saveObjPtr, *oldObjResultPtr;
+
+ result = NULL;
+ if (tvarPtr->errMsg != NULL) {
+ ckfree(tvarPtr->errMsg);
+ tvarPtr->errMsg = 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 = "";
+ }
+ Tcl_DStringInit(&cmd);
+ Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
+ Tcl_DStringAppendElement(&cmd, name1);
+ Tcl_DStringAppendElement(&cmd, name2);
+ if (flags & TCL_TRACE_READS) {
+ Tcl_DStringAppend(&cmd, " r", 2);
+ } else if (flags & TCL_TRACE_WRITES) {
+ Tcl_DStringAppend(&cmd, " w", 2);
+ } else if (flags & TCL_TRACE_UNSETS) {
+ Tcl_DStringAppend(&cmd, " u", 2);
+ }
+
+ /*
+ * Execute the command. Be careful to save and restore both the
+ * string and object results from the interpreter used for
+ * the command. We discard any object result the command returns.
+ */
+
+ dummy.objResultPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(dummy.objResultPtr);
+ 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;
+ interp->freeProc = (Tcl_FreeProc *) 0;
+ }
+
+ saveObjPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(saveObjPtr);
+
+ code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
+ if (code != TCL_OK) { /* copy error msg to result */
+ tvarPtr->errMsg = (char *)
+ ckalloc((unsigned) (strlen(interp->result) + 1));
+ strcpy(tvarPtr->errMsg, interp->result);
+ result = tvarPtr->errMsg;
+ Tcl_ResetResult(interp); /* must clear error state. */
+ }
+
+ /*
+ * Restore the interpreter's string result.
+ */
+
+ Tcl_SetResult(interp, dummy.result,
+ (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
+
+ /*
+ * Restore the interpreter's object result from saveObjPtr.
+ */
+
+ oldObjResultPtr = iPtr->objResultPtr;
+ iPtr->objResultPtr = saveObjPtr; /* was incremented above */
+ Tcl_DecrRefCount(oldObjResultPtr);
+
+ Tcl_DecrRefCount(dummy.objResultPtr);
+ dummy.objResultPtr = NULL;
+ Tcl_DStringFree(&cmd);
+ }
+ if (flags & TCL_TRACE_DESTROYED) {
+ result = NULL;
+ if (tvarPtr->errMsg != NULL) {
+ ckfree(tvarPtr->errMsg);
+ }
+ 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.
+ *
+ * With the bytecode compiler, this procedure is only called when
+ * a command name is computed at runtime, and is "while" or the name
+ * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
+ *
+ * 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]);
+ if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
+ 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;
+}
+