diff options
| -rw-r--r-- | generic/tclCmdAH.c | 70 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 5 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 25 | ||||
| -rw-r--r-- | generic/tclEnv.c | 4 | ||||
| -rw-r--r-- | generic/tclScan.c | 131 | ||||
| -rw-r--r-- | generic/tclStringObj.c | 45 |
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 } /* |