home *** CD-ROM | disk | FTP | other *** search
Text File | 1991-11-15 | 38.4 KB | 1,480 lines |
- Newsgroups: comp.sources.misc
- From: karl@sugar.neosoft.com (Karl Lehenbauer)
- Subject: v25i096: tcl - tool command language, version 6.1, Part28/33
- Message-ID: <1991Nov15.225840.21930@sparky.imd.sterling.com>
- X-Md4-Signature: edb34012633cbc906ba12f47383b7290
- Date: Fri, 15 Nov 1991 22:58:40 GMT
- Approved: kent@sparky.imd.sterling.com
-
- Submitted-by: karl@sugar.neosoft.com (Karl Lehenbauer)
- Posting-number: Volume 25, Issue 96
- Archive-name: tcl/part28
- Environment: UNIX
-
- #! /bin/sh
- # This is a shell archive. Remove anything before this line, then unpack
- # it by saving it into a file and typing "sh file". To overwrite existing
- # files, type "sh file -c". You can also feed this as standard input via
- # unshar, or by typing "sh <file", e.g.. If this archive is complete, you
- # will see the following message at the end:
- # "End of archive 28 (of 33)."
- # Contents: tcl6.1/tclCmdMZ.c
- # Wrapped by karl@one on Tue Nov 12 19:44:31 1991
- PATH=/bin:/usr/bin:/usr/ucb ; export PATH
- if test -f 'tcl6.1/tclCmdMZ.c' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'tcl6.1/tclCmdMZ.c'\"
- else
- echo shar: Extracting \"'tcl6.1/tclCmdMZ.c'\" \(35722 characters\)
- sed "s/^X//" >'tcl6.1/tclCmdMZ.c' <<'END_OF_FILE'
- X/*
- X * tclCmdMZ.c --
- X *
- X * This file contains the top-level command routines for most of
- X * the Tcl built-in commands whose names begin with the letters
- X * M to Z. It contains only commands in the generic core (i.e.
- X * those that don't depend much upon UNIX facilities).
- X *
- X * Copyright 1987-1991 Regents of the University of California
- X * Permission to use, copy, modify, and distribute this
- X * software and its documentation for any purpose and without
- X * fee is hereby granted, provided that the above copyright
- X * notice appear in all copies. The University of California
- X * makes no representations about the suitability of this
- X * software for any purpose. It is provided "as is" without
- X * express or implied warranty.
- X */
- X
- X#ifndef lint
- Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.12 91/10/27 16:17:07 ouster Exp $ SPRITE (Berkeley)";
- X#endif
- X
- X#include "tclInt.h"
- X
- X/*
- X * Structure used to hold information about variable traces:
- X */
- X
- Xtypedef struct {
- X int flags; /* Operations for which Tcl command is
- X * to be invoked. */
- X int length; /* Number of non-NULL chars. in command. */
- X char command[4]; /* Space for Tcl command to invoke. Actual
- X * size will be as large as necessary to
- X * hold command. This field must be the
- X * last in the structure, so that it can
- X * be larger than 4 bytes. */
- X} TraceVarInfo;
- X
- X/*
- X * Forward declarations for procedures defined in this file:
- X */
- X
- Xstatic char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
- X Tcl_Interp *interp, char *name1, char *name2,
- X int flags));
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_RegexpCmd --
- X *
- X * This procedure is invoked to process the "regexp" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_RegexpCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X int noCase = 0;
- X int indices = 0;
- X regexp *regexpPtr;
- X char **argPtr, *string;
- X int match, i;
- X
- X if (argc < 3) {
- X wrongNumArgs:
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " ?-nocase? exp string ?matchVar? ?subMatchVar ",
- X "subMatchVar ...?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X argPtr = argv+1;
- X argc--;
- X while ((argc > 0) && (argPtr[0][0] == '-')) {
- X if (strcmp(argPtr[0], "-indices") == 0) {
- X argPtr++;
- X argc--;
- X indices = 1;
- X } else if (strcmp(argPtr[0], "-nocase") == 0) {
- X argPtr++;
- X argc--;
- X noCase = 1;
- X } else {
- X break;
- X }
- X }
- X if (argc < 2) {
- X goto wrongNumArgs;
- X }
- X regexpPtr = TclCompileRegexp(interp, argPtr[0]);
- X if (regexpPtr == NULL) {
- X return TCL_ERROR;
- X }
- X
- X /*
- X * Convert the string to lower case, if desired, and perform
- X * the match.
- X */
- X
- X if (noCase) {
- X register char *dst, *src;
- X
- X string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
- X for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
- X if (isupper(*src)) {
- X *dst = tolower(*src);
- X } else {
- X *dst = *src;
- X }
- X }
- X *dst = 0;
- X } else {
- X string = argPtr[1];
- X }
- X tclRegexpError = NULL;
- X match = regexec(regexpPtr, string);
- X if (string != argPtr[1]) {
- X ckfree(string);
- X }
- X if (tclRegexpError != NULL) {
- X Tcl_AppendResult(interp, "error while matching pattern: ",
- X tclRegexpError, (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (!match) {
- X interp->result = "0";
- X return TCL_OK;
- X }
- X
- X /*
- X * If additional variable names have been specified, return
- X * index information in those variables.
- X */
- X
- X argc -= 2;
- X if (argc > NSUBEXP) {
- X interp->result = "too many substring variables";
- X return TCL_ERROR;
- X }
- X for (i = 0; i < argc; i++) {
- X char *result, info[50];
- X
- X if (regexpPtr->startp[i] == NULL) {
- X if (indices) {
- X result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
- X } else {
- X result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
- X }
- X } else {
- X if (indices) {
- X sprintf(info, "%d %d", regexpPtr->startp[i] - string,
- X regexpPtr->endp[i] - string - 1);
- X result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
- X } else {
- X char savedChar, *first, *last;
- X
- X first = argPtr[1] + (regexpPtr->startp[i] - string);
- X last = argPtr[1] + (regexpPtr->endp[i] - string);
- X savedChar = *last;
- X *last = 0;
- X result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
- X *last = savedChar;
- X }
- X }
- X if (result == NULL) {
- X Tcl_AppendResult(interp, "couldn't set variable \"",
- X argPtr[i+2], "\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X }
- X interp->result = "1";
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_RegsubCmd --
- X *
- X * This procedure is invoked to process the "regsub" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_RegsubCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X int noCase = 0, all = 0;
- X regexp *regexpPtr;
- X char *string, *p, *firstChar, *newValue, **argPtr;
- X int match, result, flags;
- X register char *src, c;
- X
- X if (argc < 5) {
- X wrongNumArgs:
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X argPtr = argv+1;
- X argc--;
- X while (argPtr[0][0] == '-') {
- X if (strcmp(argPtr[0], "-nocase") == 0) {
- X argPtr++;
- X argc--;
- X noCase = 1;
- X } else if (strcmp(argPtr[0], "-all") == 0) {
- X argPtr++;
- X argc--;
- X all = 1;
- X } else {
- X break;
- X }
- X }
- X if (argc != 4) {
- X goto wrongNumArgs;
- X }
- X regexpPtr = TclCompileRegexp(interp, argPtr[0]);
- X if (regexpPtr == NULL) {
- X return TCL_ERROR;
- X }
- X
- X /*
- X * Convert the string to lower case, if desired.
- X */
- X
- X if (noCase) {
- X register char *dst;
- X
- X string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
- X for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
- X if (isupper(*src)) {
- X *dst = tolower(*src);
- X } else {
- X *dst = *src;
- X }
- X }
- X *dst = 0;
- X } else {
- X string = argPtr[1];
- X }
- X
- X /*
- X * The following loop is to handle multiple matches within the
- X * same source string; each iteration handles one match and its
- X * corresponding substitution. If "-all" hasn't been specified
- X * then the loop body only gets executed once.
- X */
- X
- X flags = 0;
- X for (p = string; *p != 0; ) {
- X tclRegexpError = NULL;
- X match = regexec(regexpPtr, p);
- X if (tclRegexpError != NULL) {
- X Tcl_AppendResult(interp, "error while matching pattern: ",
- X tclRegexpError, (char *) NULL);
- X result = TCL_ERROR;
- X goto done;
- X }
- X if (!match) {
- X break;
- X }
- X
- X /*
- X * Copy the portion of the source string before the match to the
- X * result variable.
- X */
- X
- X src = argPtr[1] + (regexpPtr->startp[0] - string);
- X c = *src;
- X *src = 0;
- X newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
- X flags);
- X *src = c;
- X flags = TCL_APPEND_VALUE;
- X if (newValue == NULL) {
- X cantSet:
- X Tcl_AppendResult(interp, "couldn't set variable \"",
- X argPtr[3], "\"", (char *) NULL);
- X result = TCL_ERROR;
- X goto done;
- X }
- X
- X /*
- X * Append the subSpec argument to the variable, making appropriate
- X * substitutions. This code is a bit hairy because of the backslash
- X * conventions and because the code saves up ranges of characters in
- X * subSpec to reduce the number of calls to Tcl_SetVar.
- X */
- X
- X for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
- X int index;
- X
- X if (c == '&') {
- X index = 0;
- X } else if (c == '\\') {
- X c = src[1];
- X if ((c >= '0') && (c <= '9')) {
- X index = c - '0';
- X } else if ((c == '\\') || (c == '&')) {
- X *src = c;
- X src[1] = 0;
- X newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
- X TCL_APPEND_VALUE);
- X *src = '\\';
- X src[1] = c;
- X if (newValue == NULL) {
- X goto cantSet;
- X }
- X firstChar = src+2;
- X src++;
- X continue;
- X } else {
- X continue;
- X }
- X } else {
- X continue;
- X }
- X if (firstChar != src) {
- X c = *src;
- X *src = 0;
- X newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
- X TCL_APPEND_VALUE);
- X *src = c;
- X if (newValue == NULL) {
- X goto cantSet;
- X }
- X }
- X if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
- X && (regexpPtr->endp[index] != NULL)) {
- X char *first, *last, saved;
- X
- X first = argPtr[1] + (regexpPtr->startp[index] - string);
- X last = argPtr[1] + (regexpPtr->endp[index] - string);
- X saved = *last;
- X *last = 0;
- X newValue = Tcl_SetVar(interp, argPtr[3], first,
- X TCL_APPEND_VALUE);
- X *last = saved;
- X if (newValue == NULL) {
- X goto cantSet;
- X }
- X }
- X if (*src == '\\') {
- X src++;
- X }
- X firstChar = src+1;
- X }
- X if (firstChar != src) {
- X if (Tcl_SetVar(interp, argPtr[3], firstChar,
- X TCL_APPEND_VALUE) == NULL) {
- X goto cantSet;
- X }
- X }
- X p = regexpPtr->endp[0];
- X if (!all) {
- X break;
- X }
- X }
- X
- X /*
- X * If there were no matches at all, then return a "0" result.
- X */
- X
- X if (p == string) {
- X interp->result = "0";
- X result = TCL_OK;
- X goto done;
- X }
- X
- X /*
- X * Copy the portion of the source string after the last match to the
- X * result variable.
- X */
- X
- X if (*p != 0) {
- X if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {
- X goto cantSet;
- X }
- X }
- X interp->result = "1";
- X result = TCL_OK;
- X
- X done:
- X if (string != argPtr[1]) {
- X ckfree(string);
- X }
- X return result;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_RenameCmd --
- X *
- X * This procedure is invoked to process the "rename" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_RenameCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X register Command *cmdPtr;
- X Interp *iPtr = (Interp *) interp;
- X Tcl_HashEntry *hPtr;
- X int new;
- X
- X if (argc != 3) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " oldName newName\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (argv[2][0] == '\0') {
- X if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
- X Tcl_AppendResult(interp, "can't delete \"", argv[1],
- X "\": command doesn't exist", (char *) NULL);
- X return TCL_ERROR;
- X }
- X return TCL_OK;
- X }
- X hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
- X if (hPtr != NULL) {
- X Tcl_AppendResult(interp, "can't rename to \"", argv[2],
- X "\": command already exists", (char *) NULL);
- X return TCL_ERROR;
- X }
- X hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
- X if (hPtr == NULL) {
- X Tcl_AppendResult(interp, "can't rename \"", argv[1],
- X "\": command doesn't exist", (char *) NULL);
- X return TCL_ERROR;
- X }
- X cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
- X Tcl_DeleteHashEntry(hPtr);
- X hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
- X Tcl_SetHashValue(hPtr, cmdPtr);
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_ReturnCmd --
- X *
- X * This procedure is invoked to process the "return" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_ReturnCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X if (argc > 2) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " ?value?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (argc == 2) {
- X Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
- X }
- X return TCL_RETURN;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_ScanCmd --
- X *
- X * This procedure is invoked to process the "scan" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_ScanCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X int arg1Length; /* Number of bytes in argument to be
- X * scanned. This gives an upper limit
- X * on string field sizes. */
- X# define MAX_FIELDS 20
- X typedef struct {
- X char fmt; /* Format for field. */
- X int size; /* How many bytes to allow for
- X * field. */
- X char *location; /* Where field will be stored. */
- X } Field;
- X Field fields[MAX_FIELDS]; /* Info about all the fields in the
- X * format string. */
- X register Field *curField;
- X int numFields = 0; /* Number of fields actually
- X * specified. */
- X int suppress; /* Current field is assignment-
- X * suppressed. */
- X int totalSize = 0; /* Number of bytes needed to store
- X * all results combined. */
- X char *results; /* Where scanned output goes. */
- X int numScanned; /* sscanf's result. */
- X register char *fmt;
- X int i, widthSpecified;
- X
- X if (argc < 3) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " string format ?varName varName ...?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X /*
- X * This procedure operates in four stages:
- X * 1. Scan the format string, collecting information about each field.
- X * 2. Allocate an array to hold all of the scanned fields.
- X * 3. Call sscanf to do all the dirty work, and have it store the
- X * parsed fields in the array.
- X * 4. Pick off the fields from the array and assign them to variables.
- X */
- X
- X arg1Length = (strlen(argv[1]) + 4) & ~03;
- X for (fmt = argv[2]; *fmt != 0; fmt++) {
- X if (*fmt != '%') {
- X continue;
- X }
- X fmt++;
- X if (*fmt == '*') {
- X suppress = 1;
- X fmt++;
- X } else {
- X suppress = 0;
- X }
- X widthSpecified = 0;
- X while (isdigit(*fmt)) {
- X widthSpecified = 1;
- X fmt++;
- X }
- X if (suppress) {
- X continue;
- X }
- X if (numFields == MAX_FIELDS) {
- X interp->result = "too many fields to scan";
- X return TCL_ERROR;
- X }
- X curField = &fields[numFields];
- X numFields++;
- X switch (*fmt) {
- X case 'D':
- X case 'O':
- X case 'X':
- X case 'd':
- X case 'o':
- X case 'x':
- X curField->fmt = 'd';
- X curField->size = sizeof(int);
- X break;
- X
- X case 's':
- X curField->fmt = 's';
- X curField->size = arg1Length;
- X break;
- X
- X case 'c':
- X if (widthSpecified) {
- X interp->result =
- X "field width may not be specified in %c conversion";
- X return TCL_ERROR;
- X }
- X curField->fmt = 'c';
- X curField->size = sizeof(int);
- X break;
- X
- X case 'E':
- X case 'F':
- X curField->fmt = 'F';
- X curField->size = sizeof(double);
- X break;
- X
- X case 'e':
- X case 'f':
- X curField->fmt = 'f';
- X curField->size = sizeof(float);
- X break;
- X
- X case '[':
- X curField->fmt = 's';
- X curField->size = arg1Length;
- X do {
- X fmt++;
- X } while (*fmt != ']');
- X break;
- X
- X default:
- X sprintf(interp->result, "bad scan conversion character \"%c\"",
- X *fmt);
- X return TCL_ERROR;
- X }
- X totalSize += curField->size;
- X }
- X
- X if (numFields != (argc-3)) {
- X interp->result =
- X "different numbers of variable names and field specifiers";
- X return TCL_ERROR;
- X }
- X
- X /*
- X * Step 2:
- X */
- X
- X results = (char *) ckalloc((unsigned) totalSize);
- X for (i = 0, totalSize = 0, curField = fields;
- X i < numFields; i++, curField++) {
- X curField->location = results + totalSize;
- X totalSize += curField->size;
- X }
- X
- X /*
- X * Step 3:
- X */
- X
- X numScanned = sscanf(argv[1], argv[2],
- X fields[0].location, fields[1].location, fields[2].location,
- X fields[3].location, fields[4].location, fields[5].location,
- X fields[6].location, fields[7].location, fields[8].location,
- X fields[9].location, fields[10].location, fields[11].location,
- X fields[12].location, fields[13].location, fields[14].location,
- X fields[15].location, fields[16].location, fields[17].location,
- X fields[18].location, fields[19].location);
- X
- X /*
- X * Step 4:
- X */
- X
- X if (numScanned < numFields) {
- X numFields = numScanned;
- X }
- X for (i = 0, curField = fields; i < numFields; i++, curField++) {
- X switch (curField->fmt) {
- X char string[120];
- X
- X case 'd':
- X sprintf(string, "%d", *((int *) curField->location));
- X if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- X storeError:
- X Tcl_AppendResult(interp,
- X "couldn't set variable \"", argv[i+3], "\"",
- X (char *) NULL);
- X ckfree((char *) results);
- X return TCL_ERROR;
- X }
- X break;
- X
- X case 'c':
- X sprintf(string, "%d", *((char *) curField->location) & 0xff);
- X if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- X goto storeError;
- X }
- X break;
- X
- X case 's':
- X if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
- X == NULL) {
- X goto storeError;
- X }
- X break;
- X
- X case 'F':
- X sprintf(string, "%g", *((double *) curField->location));
- X if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- X goto storeError;
- X }
- X break;
- X
- X case 'f':
- X sprintf(string, "%g", *((float *) curField->location));
- X if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- X goto storeError;
- X }
- X break;
- X }
- X }
- X ckfree(results);
- X sprintf(interp->result, "%d", numScanned);
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_SplitCmd --
- X *
- X * This procedure is invoked to process the "split" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_SplitCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X char *splitChars;
- X register char *p, *p2;
- X char *elementStart;
- X
- X if (argc == 2) {
- X splitChars = " \n\t\r";
- X } else if (argc == 3) {
- X splitChars = argv[2];
- X } else {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " string ?splitChars?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X /*
- X * Handle the special case of splitting on every character.
- X */
- X
- X if (*splitChars == 0) {
- X char string[2];
- X string[1] = 0;
- X for (p = argv[1]; *p != 0; p++) {
- X string[0] = *p;
- X Tcl_AppendElement(interp, string, 0);
- X }
- X return TCL_OK;
- X }
- X
- X /*
- X * Normal case: split on any of a given set of characters.
- X * Discard instances of the split characters.
- X */
- X
- X for (p = elementStart = argv[1]; *p != 0; p++) {
- X char c = *p;
- X for (p2 = splitChars; *p2 != 0; p2++) {
- X if (*p2 == c) {
- X *p = 0;
- X Tcl_AppendElement(interp, elementStart, 0);
- X *p = c;
- X elementStart = p+1;
- X break;
- X }
- X }
- X }
- X if (p != argv[1]) {
- X Tcl_AppendElement(interp, elementStart, 0);
- X }
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_StringCmd --
- X *
- X * This procedure is invoked to process the "string" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_StringCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X int length;
- X register char *p, c;
- X int match;
- X int first;
- X int left = 0, right = 0;
- X
- X if (argc < 2) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " option arg ?arg ...?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X c = argv[1][0];
- X length = strlen(argv[1]);
- X if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
- X if (argc != 4) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " compare string1 string2\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X match = strcmp(argv[2], argv[3]);
- X if (match > 0) {
- X interp->result = "1";
- X } else if (match < 0) {
- X interp->result = "-1";
- X } else {
- X interp->result = "0";
- X }
- X return TCL_OK;
- X } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
- X if (argc != 4) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " first string1 string2\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X first = 1;
- X
- X firstLast:
- X match = -1;
- X c = *argv[2];
- X length = strlen(argv[2]);
- X for (p = argv[3]; *p != 0; p++) {
- X if (*p != c) {
- X continue;
- X }
- X if (strncmp(argv[2], p, length) == 0) {
- X match = p-argv[3];
- X if (first) {
- X break;
- X }
- X }
- X }
- X sprintf(interp->result, "%d", match);
- X return TCL_OK;
- X } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
- X int index;
- X
- X if (argc != 4) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " index string charIndex\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X if ((index >= 0) && (index < strlen(argv[2]))) {
- X interp->result[0] = argv[2][index];
- X interp->result[1] = 0;
- X }
- X return TCL_OK;
- X } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
- X && (length >= 2)) {
- X if (argc != 4) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " last string1 string2\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X first = 0;
- X goto firstLast;
- X } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
- X && (length >= 2)) {
- X if (argc != 3) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " length string\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X sprintf(interp->result, "%d", strlen(argv[2]));
- X return TCL_OK;
- X } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
- X if (argc != 4) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " match pattern string\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
- X interp->result = "1";
- X } else {
- X interp->result = "0";
- X }
- X return TCL_OK;
- X } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
- X int first, last, stringLength;
- X
- X if (argc != 5) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " range string first last\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X stringLength = strlen(argv[2]);
- X if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X if ((*argv[4] == 'e')
- X && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
- X last = stringLength-1;
- X } else {
- X if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
- X Tcl_ResetResult(interp);
- X Tcl_AppendResult(interp,
- X "expected integer or \"end\" but got \"",
- X argv[4], "\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X }
- X if (first < 0) {
- X first = 0;
- X }
- X if (last >= stringLength) {
- X last = stringLength-1;
- X }
- X if (last >= first) {
- X char saved, *p;
- X
- X p = argv[2] + last + 1;
- X saved = *p;
- X *p = 0;
- X Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
- X *p = saved;
- X }
- X return TCL_OK;
- X } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
- X && (length >= 3)) {
- X register char *p;
- X
- X if (argc != 3) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " tolower string\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
- X for (p = interp->result; *p != 0; p++) {
- X if (isupper(*p)) {
- X *p = tolower(*p);
- X }
- X }
- X return TCL_OK;
- X } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
- X && (length >= 3)) {
- X register char *p;
- X
- X if (argc != 3) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " toupper string\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
- X for (p = interp->result; *p != 0; p++) {
- X if (islower(*p)) {
- X *p = toupper(*p);
- X }
- X }
- X return TCL_OK;
- X } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
- X && (length == 4)) {
- X char *trimChars;
- X register char *p, *checkPtr;
- X
- X left = right = 1;
- X
- X trim:
- X if (argc == 4) {
- X trimChars = argv[3];
- X } else if (argc == 3) {
- X trimChars = " \t\n\r";
- X } else {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " ", argv[1], " string ?chars?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X p = argv[2];
- X if (left) {
- X for (c = *p; c != 0; p++, c = *p) {
- X for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
- X if (*checkPtr == 0) {
- X goto doneLeft;
- X }
- X }
- X }
- X }
- X doneLeft:
- X Tcl_SetResult(interp, p, TCL_VOLATILE);
- X if (right) {
- X char *donePtr;
- X
- X p = interp->result + strlen(interp->result) - 1;
- X donePtr = &interp->result[-1];
- X for (c = *p; p != donePtr; p--, c = *p) {
- X for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
- X if (*checkPtr == 0) {
- X goto doneRight;
- X }
- X }
- X }
- X doneRight:
- X p[1] = 0;
- X }
- X return TCL_OK;
- X } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
- X && (length > 4)) {
- X left = 1;
- X argv[1] = "trimleft";
- X goto trim;
- X } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
- X && (length > 4)) {
- X right = 1;
- X argv[1] = "trimright";
- X goto trim;
- X } else {
- X Tcl_AppendResult(interp, "bad option \"", argv[1],
- X "\": should be compare, first, index, last, length, match, ",
- X "range, tolower, toupper, trim, trimleft, or trimright",
- X (char *) NULL);
- X return TCL_ERROR;
- X }
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_TraceCmd --
- X *
- X * This procedure is invoked to process the "trace" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_TraceCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X char c;
- X int length;
- X
- X if (argc < 2) {
- X Tcl_AppendResult(interp, "too few args: should be \"",
- X argv[0], " option [arg arg ...]\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X c = argv[1][1];
- X length = strlen(argv[1]);
- X if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
- X && (length >= 2)) {
- X char *p;
- X int flags, length;
- X TraceVarInfo *tvarPtr;
- X
- X if (argc != 5) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"",
- X argv[0], " variable name ops command\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X flags = 0;
- X for (p = argv[3] ; *p != 0; p++) {
- X if (*p == 'r') {
- X flags |= TCL_TRACE_READS;
- X } else if (*p == 'w') {
- X flags |= TCL_TRACE_WRITES;
- X } else if (*p == 'u') {
- X flags |= TCL_TRACE_UNSETS;
- X } else {
- X goto badOps;
- X }
- X }
- X if (flags == 0) {
- X goto badOps;
- X }
- X
- X length = strlen(argv[4]);
- X tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
- X (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
- X tvarPtr->flags = flags;
- X tvarPtr->length = length;
- X flags |= TCL_TRACE_UNSETS;
- X strcpy(tvarPtr->command, argv[4]);
- X if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
- X (ClientData) tvarPtr) != TCL_OK) {
- X ckfree((char *) tvarPtr);
- X return TCL_ERROR;
- X }
- X } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
- X && (length >= 2)) == 0) {
- X char *p;
- X int flags, length;
- X TraceVarInfo *tvarPtr;
- X ClientData clientData;
- X
- X if (argc != 5) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"",
- X argv[0], " vdelete name ops command\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X flags = 0;
- X for (p = argv[3] ; *p != 0; p++) {
- X if (*p == 'r') {
- X flags |= TCL_TRACE_READS;
- X } else if (*p == 'w') {
- X flags |= TCL_TRACE_WRITES;
- X } else if (*p == 'u') {
- X flags |= TCL_TRACE_UNSETS;
- X } else {
- X goto badOps;
- X }
- X }
- X if (flags == 0) {
- X goto badOps;
- X }
- X
- X /*
- X * Search through all of our traces on this variable to
- X * see if there's one with the given command. If so, then
- X * delete the first one that matches.
- X */
- X
- X length = strlen(argv[4]);
- X clientData = 0;
- X while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
- X TraceVarProc, clientData)) != 0) {
- X tvarPtr = (TraceVarInfo *) clientData;
- X if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
- X && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
- X Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
- X TraceVarProc, clientData);
- X ckfree((char *) tvarPtr);
- X break;
- X }
- X }
- X } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
- X && (length >= 2)) {
- X ClientData clientData;
- X char ops[4], *p;
- X char *prefix = "{";
- X
- X if (argc != 3) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"",
- X argv[0], " vinfo name\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X clientData = 0;
- X while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
- X TraceVarProc, clientData)) != 0) {
- X TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
- X p = ops;
- X if (tvarPtr->flags & TCL_TRACE_READS) {
- X *p = 'r';
- X p++;
- X }
- X if (tvarPtr->flags & TCL_TRACE_WRITES) {
- X *p = 'w';
- X p++;
- X }
- X if (tvarPtr->flags & TCL_TRACE_UNSETS) {
- X *p = 'u';
- X p++;
- X }
- X *p = '\0';
- X Tcl_AppendResult(interp, prefix, (char *) NULL);
- X Tcl_AppendElement(interp, ops, 1);
- X Tcl_AppendElement(interp, tvarPtr->command, 0);
- X Tcl_AppendResult(interp, "}", (char *) NULL);
- X tvarPtr->command[tvarPtr->length] = ' ';
- X prefix = " {";
- X }
- X } else {
- X Tcl_AppendResult(interp, "bad option \"", argv[1],
- X "\": should be variable, vdelete, or vinfo",
- X (char *) NULL);
- X return TCL_ERROR;
- X }
- X return TCL_OK;
- X
- X badOps:
- X Tcl_AppendResult(interp, "bad operations \"", argv[3],
- X "\": should be one or more of rwu", (char *) NULL);
- X return TCL_ERROR;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * TraceVarProc --
- X *
- X * This procedure is called to handle variable accesses that have
- X * been traced using the "trace" command.
- X *
- X * Results:
- X * Normally returns NULL. If the trace command returns an error,
- X * then this procedure returns an error string.
- X *
- X * Side effects:
- X * Depends on the command associated with the trace.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xstatic char *
- XTraceVarProc(clientData, interp, name1, name2, flags)
- X ClientData clientData; /* Information about the variable trace. */
- X Tcl_Interp *interp; /* Interpreter containing variable. */
- X char *name1; /* Name of variable or array. */
- X char *name2; /* Name of element within array; NULL means
- X * scalar variable is being referenced. */
- X int flags; /* OR-ed bits giving operation and other
- X * information. */
- X{
- X TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
- X char *result;
- X int code, cmdLength, flags1, flags2;
- X Interp dummy;
- X#define STATIC_SIZE 199
- X char staticSpace[STATIC_SIZE+1];
- X char *cmdPtr, *p;
- X
- X result = NULL;
- X if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
- X
- X /*
- X * Generate a command to execute by appending list elements
- X * for the two variable names and the operation. The five
- X * extra characters are for three space, the opcode character,
- X * and the terminating null.
- X */
- X
- X if (name2 == NULL) {
- X name2 = "";
- X }
- X cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) +
- X Tcl_ScanElement(name2, &flags2) + 5;
- X if (cmdLength < STATIC_SIZE) {
- X cmdPtr = staticSpace;
- X } else {
- X cmdPtr = (char *) ckalloc((unsigned) cmdLength);
- X }
- X p = cmdPtr;
- X strcpy(p, tvarPtr->command);
- X p += tvarPtr->length;
- X *p = ' ';
- X p++;
- X p += Tcl_ConvertElement(name1, p, flags1);
- X *p = ' ';
- X p++;
- X p += Tcl_ConvertElement(name2, p, flags2);
- X *p = ' ';
- X if (flags & TCL_TRACE_READS) {
- X p[1] = 'r';
- X } else if (flags & TCL_TRACE_WRITES) {
- X p[1] = 'w';
- X } else if (flags & TCL_TRACE_UNSETS) {
- X p[1] = 'u';
- X }
- X p[2] = '\0';
- X
- X /*
- X * Execute the command. Be careful to save and restore the
- X * result from the interpreter used for the command.
- X */
- X
- X dummy.freeProc = interp->freeProc;
- X if (interp->freeProc == 0) {
- X Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
- X } else {
- X dummy.result = interp->result;
- X }
- X code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL);
- X if (cmdPtr != staticSpace) {
- X ckfree(cmdPtr);
- X }
- X if (code != TCL_OK) {
- X result = "access disallowed by trace command";
- X Tcl_ResetResult(interp); /* Must clear error state. */
- X }
- X Tcl_FreeResult(interp);
- X interp->result = dummy.result;
- X interp->freeProc = dummy.freeProc;
- X }
- X if (flags & TCL_TRACE_DESTROYED) {
- X ckfree((char *) tvarPtr);
- X }
- X return result;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_WhileCmd --
- X *
- X * This procedure is invoked to process the "while" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_WhileCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X int result, value;
- X
- X if (argc != 3) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"",
- X argv[0], " test command\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X while (1) {
- X result = Tcl_ExprBoolean(interp, argv[1], &value);
- X if (result != TCL_OK) {
- X return result;
- X }
- X if (!value) {
- X break;
- X }
- X result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);
- X if (result == TCL_CONTINUE) {
- X result = TCL_OK;
- X } else if (result != TCL_OK) {
- X if (result == TCL_ERROR) {
- X char msg[60];
- X sprintf(msg, "\n (\"while\" body line %d)",
- X interp->errorLine);
- X Tcl_AddErrorInfo(interp, msg);
- X }
- X break;
- X }
- X }
- X if (result == TCL_BREAK) {
- X result = TCL_OK;
- X }
- X if (result == TCL_OK) {
- X Tcl_ResetResult(interp);
- X }
- X return result;
- X}
- END_OF_FILE
- if test 35722 -ne `wc -c <'tcl6.1/tclCmdMZ.c'`; then
- echo shar: \"'tcl6.1/tclCmdMZ.c'\" unpacked with wrong size!
- fi
- # end of 'tcl6.1/tclCmdMZ.c'
- fi
- echo shar: End of archive 28 \(of 33\).
- cp /dev/null ark28isdone
- MISSING=""
- for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
- if test ! -f ark${I}isdone ; then
- MISSING="${MISSING} ${I}"
- fi
- done
- if test "${MISSING}" = "" ; then
- echo You have unpacked all 33 archives.
- rm -f ark[1-9]isdone ark[1-9][0-9]isdone
- else
- echo You still need to unpack the following archives:
- echo " " ${MISSING}
- fi
- ## End of shell archive.
- exit 0
-
- exit 0 # Just in case...
- --
- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
- Sterling Software, IMD UUCP: uunet!sparky!kent
- Phone: (402) 291-8300 FAX: (402) 291-4362
- Please send comp.sources.misc-related mail to kent@uunet.uu.net.
-