talexander
/
freebsd_amp_hwpstate
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
freebsd_amp_hwpstate/contrib/tcl/generic/tclCmdMZ.c

2150 lines
52 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/*
* 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.99 97/05/19 17:37:17
*/
#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_SplitCmd --
*
* 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_SplitCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
char *splitChars;
register char *p, *p2;
char *elementStart;
if (argc == 2) {
splitChars = " \n\t\r";
} else if (argc == 3) {
splitChars = argv[2];
} else {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" string ?splitChars?\"", (char *) NULL);
return TCL_ERROR;
}
/*
* Handle the special case of splitting on every character.
*/
if (*splitChars == 0) {
char string[2];
string[1] = 0;
for (p = argv[1]; *p != 0; p++) {
string[0] = *p;
Tcl_AppendElement(interp, string);
}
return TCL_OK;
}
/*
* Normal case: split on any of a given set of characters.
* Discard instances of the split characters.
*/
for (p = elementStart = argv[1]; *p != 0; p++) {
char c = *p;
for (p2 = splitChars; *p2 != 0; p2++) {
if (*p2 == c) {
*p = 0;
Tcl_AppendElement(interp, elementStart);
*p = c;
elementStart = p+1;
break;
}
}
}
if (p != argv[1]) {
Tcl_AppendElement(interp, elementStart);
}
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, first, 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: {
first = 1;
goto firstlast;
}
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: {
char *p, *end;
int match;
first = 0;
firstlast:
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);
match = -1;
end = string2 + length2 - length1 + 1;
for (p = string2; p < end; p++) {
if (memcmp(string1, p, (unsigned) length1) == 0) {
match = p - string2;
if (first) {
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: {
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: {
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;
char *p, *end, *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;
string = Tcl_GetStringFromObj(switchObjv[0], &length);
while ((switchObjc > 0) && (*string == '-')) {
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++;
string = Tcl_GetStringFromObj(switchObjv[0], &length);
}
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 */
TclDecrRefCount(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;
}
Reference in New Issue View Git Blame Copy Permalink