summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclCmdAH.c70
-rw-r--r--generic/tclCmdMZ.c5
-rw-r--r--generic/tclCompCmds.c25
-rw-r--r--generic/tclEnv.c4
-rw-r--r--generic/tclScan.c131
-rw-r--r--generic/tclStringObj.c45
6 files changed, 231 insertions, 49 deletions
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index b86ea42..3e4de89 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.9 1999/09/21 04:20:39 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.10 1999/10/29 03:03:59 hobbs Exp $
*/
#include "tclInt.h"
@@ -827,13 +827,41 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
switch ((enum options) index) {
case FILE_ATIME: {
struct stat buf;
-
- if (objc != 3) {
- goto only3Args;
+ char *fileName;
+ struct utimbuf tval;
+
+ if ((objc < 3) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
+ return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
+ if (objc == 4) {
+ if (Tcl_GetLongFromObj(interp, objv[3],
+ (long*)(&buf.st_atime)) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ tval.actime = buf.st_atime;
+ tval.modtime = buf.st_mtime;
+ fileName = Tcl_GetString(objv[2]);
+ if (utime(fileName, &tval) != 0) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "could not set access time for file \"",
+ fileName, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+ /*
+ * Do another stat to ensure that the we return the
+ * new recognized atime - hopefully the same as the
+ * one we sent in. However, fs's like FAT don't
+ * even know what atime is.
+ */
+ if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
Tcl_SetLongObj(resultPtr, (long) buf.st_atime);
return TCL_OK;
}
@@ -986,13 +1014,41 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
}
case FILE_MTIME: {
struct stat buf;
-
- if (objc != 3) {
- goto only3Args;
+ char *fileName;
+ struct utimbuf tval;
+
+ if ((objc < 3) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
+ return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
+ if (objc == 4) {
+ if (Tcl_GetLongFromObj(interp, objv[3],
+ (long*)(&buf.st_mtime)) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ tval.actime = buf.st_atime;
+ tval.modtime = buf.st_mtime;
+ fileName = Tcl_GetString(objv[2]);
+ if (utime(fileName, &tval) != 0) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "could not set modification time for file \"",
+ fileName, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+ /*
+ * Do another stat to ensure that the we return the
+ * new recognized atime - hopefully the same as the
+ * one we sent in. However, fs's like FAT don't
+ * even know what atime is.
+ */
+ if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
Tcl_SetLongObj(resultPtr, (long) buf.st_mtime);
return TCL_OK;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index bd00b56..86ed11e 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.21 1999/10/21 02:16:21 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.22 1999/10/29 03:03:59 hobbs Exp $
*/
#include "tclInt.h"
@@ -1109,7 +1109,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
&index) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_SetByteArrayObj(resultPtr, &string1[index], 1);
+ Tcl_SetByteArrayObj(resultPtr,
+ (unsigned char *)(&string1[index]), 1);
} else {
string1 = Tcl_GetStringFromObj(objv[2], &length1);
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 9566a2f..5577bf1 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompCmds.c,v 1.3 1999/08/19 02:59:08 hobbs Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.4 1999/10/29 03:04:00 hobbs Exp $
*/
#include "tclInt.h"
@@ -1341,7 +1341,16 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
+ * curly braces surround the variable name.
+ * This really matters for array elements to handle things like
+ * set {x($foo)} 5
+ * which raises an undefined var error if we are not careful here.
+ * This goes with the hack in TclCompileSetCmd.
+ */
+ if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
+ (varTokenPtr->start[0] != '{')) {
/*
* A simple variable name. Divide it up into "name" and "elName"
* strings. If it is not a local variable, look it up at runtime.
@@ -1600,8 +1609,18 @@ TclCompileSetCmd(interp, parsePtr, envPtr)
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
+ * curly braces surround the variable name.
+ * This really matters for array elements to handle things like
+ * set {x($foo)} 5
+ * which raises an undefined var error if we are not careful here.
+ * This goes with the hack in TclCompileIncrCmd.
+ */
+ if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
+ (varTokenPtr->start[0] != '{')) {
simpleVarName = 1;
+
name = varTokenPtr[1].start;
nameChars = varTokenPtr[1].size;
/* last char is ')' => potential array reference */
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index f601da5..49984c9 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEnv.c,v 1.5 1999/10/13 00:32:17 hobbs Exp $
+ * RCS: @(#) $Id: tclEnv.c,v 1.6 1999/10/29 03:04:00 hobbs Exp $
*/
#include "tclInt.h"
@@ -251,7 +251,7 @@ TclSetEnv(name, value)
* update the string in the cache.
*/
- if (environ[index] == p) {
+ if ((index != -1) && (environ[index] == p)) {
ReplaceString(oldValue, p);
}
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 92b192c..868239a 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclScan.c,v 1.2 1999/04/16 00:46:53 stanton Exp $
+ * RCS: @(#) $Id: tclScan.c,v 1.3 1999/10/29 03:04:00 hobbs Exp $
*/
#include "tclInt.h"
@@ -54,7 +54,7 @@ static char * BuildCharSet _ANSI_ARGS_((CharSet *cset, char *format));
static int CharInSet _ANSI_ARGS_((CharSet *cset, int ch));
static void ReleaseCharSet _ANSI_ARGS_((CharSet *cset));
static int ValidateFormat _ANSI_ARGS_((Tcl_Interp *interp, char *format,
- int numVars));
+ int numVars, int *totalVars));
/*
*----------------------------------------------------------------------
@@ -255,17 +255,21 @@ ReleaseCharSet(cset)
*/
static int
-ValidateFormat(interp, format, numVars)
+ValidateFormat(interp, format, numVars, totalSubs)
Tcl_Interp *interp; /* Current interpreter. */
char *format; /* The format string. */
int numVars; /* The number of variables passed to the
* scan command. */
+ int *totalSubs; /* The number of variables that will be
+ * required. */
{
+#define STATIC_LIST_SIZE 16
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch;
- int *nassign = (int*)ckalloc(sizeof(int) * numVars);
- int objIndex;
+ int staticAssign[STATIC_LIST_SIZE];
+ int *nassign = staticAssign;
+ int objIndex, nspace = STATIC_LIST_SIZE;
/*
* Initialize an array that records the number of times a variable
@@ -273,9 +277,14 @@ ValidateFormat(interp, format, numVars)
* a variable is multiply assigned or left unassigned.
*/
- for (i = 0; i < numVars; i++) {
+ if (numVars > nspace) {
+ nassign = (int*)ckalloc(sizeof(int) * numVars);
+ nspace = numVars;
+ }
+ for (i = 0; i < nspace; i++) {
nassign[i] = 0;
}
+ //memset(nassign, 0, nspace * sizeof(int));
objIndex = gotXpg = gotSequential = 0;
@@ -350,7 +359,7 @@ ValidateFormat(interp, format, numVars)
format += Tcl_UtfToUniChar(format, &ch);
}
- if (!(flags & SCAN_SUPPRESS) && objIndex >= numVars) {
+ if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
goto badIndex;
}
@@ -415,6 +424,26 @@ ValidateFormat(interp, format, numVars)
}
}
if (!(flags & SCAN_SUPPRESS)) {
+ if (objIndex >= nspace) {
+ /*
+ * Expand the nassign buffer
+ */
+ nspace += STATIC_LIST_SIZE;
+ if (nassign == staticAssign) {
+ nassign = (void *)ckalloc(nspace * sizeof(int));
+ for (i = 0; i < STATIC_LIST_SIZE; ++i) {
+ nassign[i] = staticAssign[i];
+ }
+ } else {
+ nassign = (void *)ckrealloc((void *)nassign,
+ nspace * sizeof(int));
+ }
+ for (i = nspace-STATIC_LIST_SIZE; i < nspace; i++) {
+ nassign[i] = 0;
+ }
+ //memset((VOID *) nassign[nspace-STATIC_LIST_SIZE], 0,
+ // STATIC_LIST_SIZE * sizeof(int));
+ }
nassign[objIndex]++;
objIndex++;
}
@@ -424,17 +453,25 @@ ValidateFormat(interp, format, numVars)
* Verify that all of the variable were assigned exactly once.
*/
+ if (numVars == 0) {
+ numVars = objIndex;
+ }
+ if (totalSubs) {
+ *totalSubs = numVars;
+ }
for (i = 0; i < numVars; i++) {
if (nassign[i] > 1) {
Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC);
goto error;
} else if (nassign[i] == 0) {
- Tcl_SetResult(interp, "variable is not assigend by any conversion specifiers", TCL_STATIC);
+ Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC);
goto error;
}
}
- ckfree((char *)nassign);
+ if (nassign != staticAssign) {
+ ckfree((char *)nassign);
+ }
return TCL_OK;
badIndex:
@@ -448,8 +485,11 @@ ValidateFormat(interp, format, numVars)
}
error:
- ckfree((char *)nassign);
+ if (nassign != staticAssign) {
+ ckfree((char *)nassign);
+ }
return TCL_ERROR;
+#undef STATIC_LIST_SIZE
}
/*
@@ -478,7 +518,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *format;
- int numVars, nconversions;
+ int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, value, result, code;
char *string, *end, *baseString;
char op = 0;
@@ -487,7 +527,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
size_t width;
long (*fn)() = NULL;
Tcl_UniChar ch, sch;
- Tcl_Obj **objs, *objPtr;
+ Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
char buf[513]; /* Temporary buffer to hold scanned
* number strings before they are
@@ -506,17 +546,19 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
* Check for errors in the format string.
*/
- if (ValidateFormat(interp, format, numVars) == TCL_ERROR) {
+ if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Allocate space for the result objects.
*/
-
- objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * numVars);
- for (i = 0; i < numVars; i++) {
- objs[i] = NULL;
+
+ if (totalVars > 0) {
+ objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars);
+ for (i = 0; i < totalVars; i++) {
+ objs[i] = NULL;
+ }
}
string = Tcl_GetStringFromObj(objv[1], NULL);
@@ -1009,24 +1051,57 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
result = 0;
code = TCL_OK;
- for (i = 0; i < numVars; i++) {
- if (objs[i] != NULL) {
- result++;
- if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "couldn't set variable \"",
- Tcl_GetString(objv[i+3]), "\"", (char *) NULL);
- code = TCL_ERROR;
+ if (numVars) {
+ /*
+ * In this case, variables were specified (classic scan)
+ */
+ for (i = 0; i < totalVars; i++) {
+ if (objs[i] != NULL) {
+ result++;
+ if (Tcl_ObjSetVar2(interp, objv[i+3], NULL,
+ objs[i], 0) == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "couldn't set variable \"",
+ Tcl_GetString(objv[i+3]), "\"", (char *) NULL);
+ code = TCL_ERROR;
+ }
+ Tcl_DecrRefCount(objs[i]);
+ }
+ }
+ } else {
+ /*
+ * Here no vars were specified, we want a list returned (inline scan)
+ */
+ objPtr = Tcl_NewObj();
+ for (i = 0; i < totalVars; i++) {
+ if (objs[i] != NULL) {
+ Tcl_ListObjAppendElement(NULL, objPtr, objs[i]);
+ Tcl_DecrRefCount(objs[i]);
+ } else {
+ /*
+ * More %-specifiers than matching chars, so we
+ * just spit out empty strings for these
+ */
+ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
}
- Tcl_DecrRefCount(objs[i]);
}
}
ckfree((char*) objs);
if (code == TCL_OK) {
if (underflow && (nconversions == 0)) {
- result = -1;
+ if (numVars) {
+ objPtr = Tcl_NewIntObj(-1);
+ } else {
+ if (objPtr) {
+ Tcl_SetListObj(objPtr, 0, NULL);
+ } else {
+ objPtr = Tcl_NewObj();
+ }
+ }
+ } else if (numVars) {
+ objPtr = Tcl_NewIntObj(result);
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
+ Tcl_SetObjResult(interp, objPtr);
}
return code;
}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index bc18fb3..f9c9589 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -33,7 +33,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStringObj.c,v 1.13 1999/09/02 16:26:34 hobbs Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.14 1999/10/29 03:04:00 hobbs Exp $ */
#include "tclInt.h"
@@ -1170,10 +1170,14 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
Tcl_Obj *objPtr; /* Points to the object to append to. */
va_list argList; /* Variable argument list. */
{
+#define STATIC_LIST_SIZE 16
String *stringPtr;
- va_list tmpArgList;
int newLength, oldLength;
register char *string, *dst;
+ char *static_list[STATIC_LIST_SIZE];
+ char **args = static_list;
+ int nargs_space = STATIC_LIST_SIZE;
+ int nargs, i;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_AppendStringsToObj called with shared object");
@@ -1188,17 +1192,33 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
* (notably OS/390) the argList is an array so we need to use memcpy.
*/
- memcpy ((VOID *) &tmpArgList, (VOID *) &argList, sizeof (tmpArgList));
+ nargs = 0;
newLength = oldLength = objPtr->length;
while (1) {
- string = va_arg(tmpArgList, char *);
+ string = va_arg(argList, char *);
if (string == NULL) {
break;
}
+ if (nargs >= nargs_space) {
+ /*
+ * Expand the args buffer
+ */
+ nargs_space += STATIC_LIST_SIZE;
+ if (args == static_list) {
+ args = (void *)ckalloc(nargs_space * sizeof(char *));
+ for (i = 0; i < nargs; ++i) {
+ args[i] = static_list[i];
+ }
+ } else {
+ args = (void *)ckrealloc((void *)args,
+ nargs_space * sizeof(char *));
+ }
+ }
newLength += strlen(string);
+ args[nargs++] = string;
}
if (newLength == oldLength) {
- return;
+ goto done;
}
stringPtr = GET_STRING(objPtr);
@@ -1222,8 +1242,8 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
*/
dst = objPtr->bytes + oldLength;
- while (1) {
- string = va_arg(argList, char *);
+ for (i = 0; i < nargs; ++i) {
+ string = args[i];
if (string == NULL) {
break;
}
@@ -1245,6 +1265,17 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
*dst = 0;
}
objPtr->length = newLength;
+
+ done:
+ /*
+ * If we had to allocate a buffer from the heap,
+ * free it now.
+ */
+
+ if (args != static_list) {
+ ckfree((void *)args);
+ }
+#undef STATIC_LIST_SIZE
}
/*