diff options
Diffstat (limited to 'generic/tclCmdAH.c')
| -rw-r--r-- | generic/tclCmdAH.c | 1442 |
1 files changed, 885 insertions, 557 deletions
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index fd31e52..8aa6880 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,24 +11,36 @@ * 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.4 1998/12/23 02:01:42 rjohnson Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.5 1999/04/16 00:46:43 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" +#include <locale.h> + +typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf)); /* * Prototypes for local procedures defined in this file: */ +static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int mode)); +static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, StatProc *statProc, + struct stat *statPtr)); static char * GetTypeFromMode _ANSI_ARGS_((int mode)); +static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr)); static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, char *varName, struct stat *statPtr)); +static char ** StringifyObjects _ANSI_ARGS_((int objc, + Tcl_Obj *CONST objv[])); /* *---------------------------------------------------------------------- * - * Tcl_BreakCmd -- + * Tcl_BreakObjCmd -- * * This procedure is invoked to process the "break" Tcl command. * See the user documentation for details on what it does. @@ -48,15 +60,14 @@ static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, /* ARGSUSED */ int -Tcl_BreakCmd(dummy, interp, argc, argv) +Tcl_BreakObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], "\"", (char *) NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return TCL_BREAK; @@ -90,7 +101,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) register int i; int body, result; char *string, *arg; - int argLen, caseObjc; + int caseObjc; Tcl_Obj *CONST *caseObjv; Tcl_Obj *armPtr; @@ -100,14 +111,10 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - - string = Tcl_GetStringFromObj(objv[1], &argLen); + string = Tcl_GetString(objv[1]); body = -1; - arg = Tcl_GetStringFromObj(objv[2], &argLen); + arg = Tcl_GetString(objv[2]); if (strcmp(arg, "in") == 0) { i = 3; } else { @@ -119,7 +126,6 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. - * THIS FAILS IF THE ARG'S STRING REP CONTAINS A NULL */ if (caseObjc == 1) { @@ -133,9 +139,9 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) int patObjc, j; char **patObjv; char *pat; - register char *p; + unsigned char *p; - if (i == (caseObjc-1)) { + if (i == (caseObjc - 1)) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "extra case pattern with no body", -1); @@ -147,18 +153,18 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) * no backslash sequences. */ - pat = Tcl_GetStringFromObj(caseObjv[i], &argLen); - for (p = pat; *p != 0; p++) { /* FAILS IF NULL BYTE */ - if (isspace(UCHAR(*p)) || (*p == '\\')) { + pat = Tcl_GetString(caseObjv[i]); + for (p = (unsigned char *) pat; *p != '\0'; p++) { + if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ break; } } - if (*p == 0) { + if (*p == '\0') { if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { - body = i+1; + body = i + 1; } if (Tcl_StringMatch(string, pat)) { - body = i+1; + body = i + 1; goto match; } continue; @@ -176,7 +182,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) } for (j = 0; j < patObjc; j++) { if (Tcl_StringMatch(string, patObjv[j])) { - body = i+1; + body = i + 1; break; } } @@ -188,13 +194,14 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) match: if (body != -1) { - armPtr = caseObjv[body-1]; - result = Tcl_EvalObj(interp, caseObjv[body]); + armPtr = caseObjv[body - 1]; + result = Tcl_EvalObjEx(interp, caseObjv[body], 0); if (result == TCL_ERROR) { - char msg[100]; + char msg[100 + TCL_INTEGER_SPACE]; - arg = Tcl_GetStringFromObj(armPtr, &argLen); - sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg, + arg = Tcl_GetString(armPtr); + sprintf(msg, + "\n (\"%.50s\" arm line %d)", arg, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } @@ -251,11 +258,11 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) varNamePtr = objv[2]; } - result = Tcl_EvalObj(interp, objv[1]); + result = Tcl_EvalObjEx(interp, objv[1], 0); if (objc == 3) { if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, - Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) { + Tcl_GetObjResult(interp), 0) == NULL) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "couldn't save command result in variable", -1); @@ -301,8 +308,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *dirName; - int dirLength; - Tcl_DString buffer; + Tcl_DString ds; int result; if (objc > 2) { @@ -311,17 +317,23 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - dirName = Tcl_GetStringFromObj(objv[1], &dirLength); + dirName = Tcl_GetString(objv[1]); } else { dirName = "~"; } - dirName = Tcl_TranslateFileName(interp, dirName, &buffer); - if (dirName == NULL) { + if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) { return TCL_ERROR; } - result = TclChdir(interp, dirName); - Tcl_DStringFree(&buffer); - return result; + + result = Tcl_Chdir(Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + + if (result != 0) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; } /* @@ -330,7 +342,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) * Tcl_ConcatObjCmd -- * * This object-based procedure is invoked to process the "concat" Tcl - * command. See the user documentation for details on what it does/ + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -358,7 +370,7 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_ContinueCmd - + * Tcl_ContinueObjCmd - * * This procedure is invoked to process the "continue" Tcl command. * See the user documentation for details on what it does. @@ -378,15 +390,14 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_ContinueCmd(dummy, interp, argc, argv) +Tcl_ContinueObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - "\"", (char *) NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return TCL_CONTINUE; @@ -395,6 +406,131 @@ Tcl_ContinueCmd(dummy, interp, argc, argv) /* *---------------------------------------------------------------------- * + * Tcl_EncodingObjCmd -- + * + * This command manipulates encodings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EncodingObjCmd(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, length; + Tcl_Encoding encoding; + char *string; + Tcl_DString ds; + Tcl_Obj *resultPtr; + + static char *optionStrings[] = { + "convertfrom", "convertto", "names", "system", + NULL + }; + enum options { + ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case ENC_CONVERTTO: + case ENC_CONVERTFROM: { + char *name; + Tcl_Obj *data; + if (objc == 3) { + name = NULL; + data = objv[2]; + } else if (objc == 4) { + name = Tcl_GetString(objv[2]); + data = objv[3]; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); + return TCL_ERROR; + } + + encoding = Tcl_GetEncoding(interp, name); + if (!encoding) { + return TCL_ERROR; + } + + if ((enum options) index == ENC_CONVERTFROM) { + /* + * Treat the string as binary data. + */ + + string = (char *) Tcl_GetByteArrayFromObj(data, &length); + Tcl_ExternalToUtfDString(encoding, string, length, &ds); + + /* + * Note that we cannot use Tcl_DStringResult here because + * it will truncate the string at the first null byte. + */ + + Tcl_SetStringObj(Tcl_GetObjResult(interp), + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } else { + /* + * Store the result as binary data. + */ + + string = Tcl_GetStringFromObj(data, &length); + Tcl_UtfToExternalDString(encoding, string, length, &ds); + resultPtr = Tcl_GetObjResult(interp); + Tcl_SetByteArrayObj(resultPtr, + (unsigned char *) Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + + Tcl_FreeEncoding(encoding); + break; + } + case ENC_NAMES: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_GetEncodingNames(interp); + break; + } + case ENC_SYSTEM: { + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + return TCL_ERROR; + } + if (objc == 2) { + Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC); + } else { + return Tcl_SetSystemEncoding(interp, + Tcl_GetStringFromObj(objv[2], NULL)); + } + break; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ErrorObjCmd -- * * This procedure is invoked to process the "error" Tcl command. @@ -418,7 +554,6 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - register Tcl_Obj *namePtr; char *info; int infoLen; @@ -436,11 +571,8 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv) } if (objc == 4) { - namePtr = Tcl_NewStringObj("errorCode", -1); - Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, objv[3], - TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY); iPtr->flags |= ERROR_CODE_SET; - Tcl_DecrRefCount(namePtr); /* we're done with name object */ } Tcl_SetObjResult(interp, objv[1]); @@ -481,7 +613,7 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - result = Tcl_EvalObj(interp, objv[1]); + result = Tcl_EvalObjEx(interp, objv[1], 0); } else { /* * More than one argument: concatenate them together with spaces @@ -489,11 +621,13 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) */ objPtr = Tcl_ConcatObj(objc-1, objv+1); - result = Tcl_EvalObj(interp, objPtr); - Tcl_DecrRefCount(objPtr); /* we're done with the object */ + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); + Tcl_DecrRefCount(objPtr); } if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } @@ -573,7 +707,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ +{ register Tcl_Obj *objPtr; Tcl_Obj *resultPtr; register char *bytes; @@ -595,7 +729,6 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) /* * Create a new object holding the concatenated argument strings. - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. */ bytes = Tcl_GetStringFromObj(objv[1], &length); @@ -652,103 +785,86 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *fileName, *extension, *errorString; - int statOp = 0; /* Init. to avoid compiler warning. */ - int length; - int mode = 0; /* Initialized only to prevent - * compiler warning message. */ - struct stat statBuf; - Tcl_DString buffer; Tcl_Obj *resultPtr; - int index, result; + int index; /* * This list of constants should match the fileOption string array below. */ -enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, - FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY, - FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR, - FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE, - FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, - FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE}; - - - static char *fileOptions[] = {"atime", "attributes", "copy", "delete", - "dirname", "executable", "exists", "extension", "isdirectory", - "isfile", "join", "lstat", "mtime", "mkdir", "nativename", - "owned", "pathtype", "readable", "readlink", "rename", - "rootname", "size", "split", "stat", "tail", "type", "volumes", - "writable", (char *) NULL}; + static char *fileOptions[] = { + "atime", "attributes", "copy", "delete", + "dirname", "executable", "exists", "extension", + "isdirectory", "isfile", "join", "lstat", + "mtime", "mkdir", "nativename", "owned", + "pathtype", "readable", "readlink", "rename", + "rootname", "size", "split", "stat", + "tail", "type", "volumes", "writable", + (char *) NULL + }; + enum options { + FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, + FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, + FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT, + FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED, + FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME, + FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT, + FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } - - if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - - result = TCL_OK; - /* - * First, do the volumes command, since it is the only one that - * has objc == 2. - */ - - if ( index == FILE_VOLUMES) { - if ( objc != 2 ) { - Tcl_WrongNumArgs(interp, 1, objv, "volumes"); - return TCL_ERROR; - } - result = TclpListVolumes(interp); - return result; - } - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?arg ...?"); - return TCL_ERROR; - } - Tcl_DStringInit(&buffer); resultPtr = Tcl_GetObjResult(interp); - - - /* - * Handle operations on the file name. - */ - - switch (index) { - case FILE_ATTRIBUTES: - result = TclFileAttrsCmd(interp, objc - 2, objv + 2); - goto done; - case FILE_DIRNAME: { - int pargc; - char **pargv; - + switch ((enum options) index) { + case FILE_ATIME: { + struct stat buf; + if (objc != 3) { - errorString = "dirname name"; - goto not3Args; + goto only3Args; + } + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } + Tcl_SetLongObj(resultPtr, (long) buf.st_atime); + return TCL_OK; + } + case FILE_ATTRIBUTES: { + return TclFileAttrsCmd(interp, objc, objv); + } + case FILE_COPY: { + int result; + char **argv; - fileName = Tcl_GetStringFromObj(objv[2], &length); + argv = StringifyObjects(objc, objv); + result = TclFileCopyCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_DELETE: { + int result; + char **argv; - /* - * If there is only one element, and it starts with a tilde, - * perform tilde substitution and resplit the path. - */ + argv = StringifyObjects(objc, objv); + result = TclFileDeleteCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_DIRNAME: { + int argc; + char **argv; - Tcl_SplitPath(fileName, &pargc, &pargv); - if ((pargc == 1) && (*fileName == '~')) { - ckfree((char*) pargv); - fileName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - Tcl_SplitPath(fileName, &pargc, &pargv); - Tcl_DStringSetLength(&buffer, 0); + if (objc != 3) { + goto only3Args; + } + if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { + return TCL_ERROR; } /* @@ -757,324 +873,209 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, * return the current directory. */ - if (pargc > 1) { - Tcl_JoinPath(pargc-1, pargv, &buffer); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), - buffer.length); - } else if ((pargc == 0) - || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, (tclPlatform == TCL_PLATFORM_MAC) - ? ":" : ".", 1); + if (argc > 1) { + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(argc - 1, argv, &ds); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } else if ((argc == 0) + || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetStringObj(resultPtr, + ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1); } else { - Tcl_SetStringObj(resultPtr, pargv[0], -1); } - ckfree((char *)pargv); - goto done; + Tcl_SetStringObj(resultPtr, argv[0], -1); + } + ckfree((char *) argv); + return TCL_OK; } - case FILE_TAIL: { - int pargc; - char **pargv; - + case FILE_EXECUTABLE: { if (objc != 3) { - errorString = "tail name"; - goto not3Args; - } - - fileName = Tcl_GetStringFromObj(objv[2], &length); - - /* - * If there is only one element, and it starts with a tilde, - * perform tilde substitution and resplit the path. - */ - - Tcl_SplitPath(fileName, &pargc, &pargv); - if ((pargc == 1) && (*fileName == '~')) { - ckfree((char*) pargv); - fileName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - Tcl_SplitPath(fileName, &pargc, &pargv); - Tcl_DStringSetLength(&buffer, 0); + goto only3Args; } - - /* - * Return the last component, unless it is the only component, - * and it is the root of an absolute path. - */ - - if (pargc > 0) { - if ((pargc > 1) - || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, pargv[pargc - 1], -1); - } - } - ckfree((char *)pargv); - goto done; + return CheckAccess(interp, objv[2], X_OK); } - case FILE_ROOTNAME: { - char *fileName; - + case FILE_EXISTS: { if (objc != 3) { - errorString = "rootname name"; - goto not3Args; - } - - fileName = Tcl_GetStringFromObj(objv[2], &length); - extension = TclGetExtension(fileName); - if (extension == NULL) { - Tcl_SetObjResult(interp, objv[2]); - } else { - Tcl_SetStringObj(resultPtr, fileName, - (int) (length - strlen(extension))); + goto only3Args; } - goto done; + return CheckAccess(interp, objv[2], F_OK); } - case FILE_EXTENSION: + case FILE_EXTENSION: { + char *fileName, *extension; if (objc != 3) { - errorString = "extension name"; - goto not3Args; + goto only3Args; } - extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length)); - + fileName = Tcl_GetString(objv[2]); + extension = TclGetExtension(fileName); if (extension != NULL) { - Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension)); + Tcl_SetStringObj(resultPtr, extension, -1); } - goto done; - case FILE_PATHTYPE: + return TCL_OK; + } + case FILE_ISDIRECTORY: { + int value; + struct stat buf; + if (objc != 3) { - errorString = "pathtype name"; - goto not3Args; + goto only3Args; } - switch (Tcl_GetPathType(Tcl_GetStringFromObj(objv[2], &length))) { - case TCL_PATH_ABSOLUTE: - Tcl_SetStringObj(resultPtr, "absolute", -1); - break; - case TCL_PATH_RELATIVE: - Tcl_SetStringObj(resultPtr, "relative", -1); - break; - case TCL_PATH_VOLUME_RELATIVE: - Tcl_SetStringObj(resultPtr, "volumerelative", -1); - break; + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); } - goto done; - case FILE_SPLIT: { - int pargc, i; - char **pargvList; - Tcl_Obj *listObjPtr; - - if (objc != 3) { - errorString = "split name"; - goto not3Args; - } - - Tcl_SplitPath(Tcl_GetStringFromObj(objv[2], &length), &pargc, - &pargvList); - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (i = 0; i < pargc; i++) { - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(pargvList[i], -1)); - } - ckfree((char *) pargvList); - Tcl_SetObjResult(interp, listObjPtr); - goto done; + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; } - case FILE_JOIN: { - char **pargv = (char **) ckalloc((objc - 2) * sizeof(char *)); - int i; + case FILE_ISFILE: { + int value; + struct stat buf; - for (i = 2; i < objc; i++) { - pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length); - } - Tcl_JoinPath(objc - 2, pargv, &buffer); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), - buffer.length); - ckfree((char *) pargv); - Tcl_DStringFree(&buffer); - goto done; - } - case FILE_RENAME: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); } - result = TclFileRenameCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; } - case FILE_MKDIR: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + case FILE_JOIN: { + char **argv; + Tcl_DString ds; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; } - result = TclFileMakeDirsCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + argv = StringifyObjects(objc - 2, objv + 2); + Tcl_DStringInit(&ds); + Tcl_JoinPath(objc - 2, argv, &ds); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + ckfree((char *) argv); + return TCL_OK; } - case FILE_DELETE: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + case FILE_LSTAT: { + char *varName; + struct stat buf; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + return TCL_ERROR; } - result = TclFileDeleteCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + varName = Tcl_GetString(objv[3]); + return StoreStatData(interp, varName, &buf); } - case FILE_COPY: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; + case FILE_MTIME: { + struct stat buf; - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + if (objc != 3) { + goto only3Args; } - result = TclFileCopyCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; - } - case FILE_NATIVENAME: - fileName = Tcl_TranslateFileName(interp, - Tcl_GetStringFromObj(objv[2], &length), &buffer); - if (fileName == NULL) { - result = TCL_ERROR ; - } else { - Tcl_SetStringObj(resultPtr, fileName, -1); + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } - goto done; - } - - /* - * Next, handle operations that can be satisfied with the "access" - * kernel call. - */ + Tcl_SetLongObj(resultPtr, (long) buf.st_mtime); + return TCL_OK; + } + case FILE_MKDIR: { + char **argv; + int result; - fileName = Tcl_TranslateFileName(interp, - Tcl_GetStringFromObj(objv[2], &length), &buffer); - - switch (index) { - case FILE_READABLE: - if (objc != 3) { - errorString = "readable name"; - goto not3Args; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; } - mode = R_OK; -checkAccess: - /* - * The result might have been set within Tcl_TranslateFileName - * (like no such user "blah" for file exists ~blah) - * but we don't want to flag an error in that case. - */ - if (fileName == NULL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - } else { - Tcl_SetBooleanObj(resultPtr, (TclAccess(fileName, mode) != -1)); - } - goto done; - case FILE_WRITABLE: + argv = StringifyObjects(objc, objv); + result = TclFileMakeDirsCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_NATIVENAME: { + char *fileName; + Tcl_DString ds; + if (objc != 3) { - errorString = "writable name"; - goto not3Args; + goto only3Args; } - mode = W_OK; - goto checkAccess; - case FILE_EXECUTABLE: - if (objc != 3) { - errorString = "executable name"; - goto not3Args; + fileName = Tcl_GetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; } - mode = X_OK; - goto checkAccess; - case FILE_EXISTS: + Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + return TCL_OK; + } + case FILE_OWNED: { + int value; + struct stat buf; + if (objc != 3) { - errorString = "exists name"; - goto not3Args; + goto only3Args; } - mode = F_OK; - goto checkAccess; - } + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + /* + * For Windows and Macintosh, there are no user ids + * associated with a file, so we always return 1. + */ - - /* - * Lastly, check stuff that requires the file to be stat-ed. - */ +#if (defined(__WIN32__) || defined(MAC_TCL)) + value = 1; +#else + value = (geteuid() == buf.st_uid); +#endif + } + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; + } + case FILE_PATHTYPE: { + char *fileName; - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - - switch (index) { - case FILE_ATIME: - if (objc != 3) { - errorString = "atime name"; - goto not3Args; - } - - if (TclStat(fileName, &statBuf) == -1) { - goto badStat; - } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_atime); - goto done; - case FILE_ISDIRECTORY: - if (objc != 3) { - errorString = "isdirectory name"; - goto not3Args; - } - statOp = 2; - break; - case FILE_ISFILE: - if (objc != 3) { - errorString = "isfile name"; - goto not3Args; - } - statOp = 1; - break; - case FILE_LSTAT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "lstat name varName"); - result = TCL_ERROR; - goto done; - } - - if (lstat(fileName, &statBuf) == -1) { - Tcl_AppendStringsToObj(resultPtr, "couldn't lstat \"", - Tcl_GetStringFromObj(objv[2], &length), "\": ", - Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; - } - result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3], - &length), &statBuf); - goto done; - case FILE_MTIME: if (objc != 3) { - errorString = "mtime name"; - goto not3Args; + goto only3Args; } - if (TclStat(fileName, &statBuf) == -1) { - goto badStat; + fileName = Tcl_GetString(objv[2]); + switch (Tcl_GetPathType(fileName)) { + case TCL_PATH_ABSOLUTE: + Tcl_SetStringObj(resultPtr, "absolute", -1); + break; + case TCL_PATH_RELATIVE: + Tcl_SetStringObj(resultPtr, "relative", -1); + break; + case TCL_PATH_VOLUME_RELATIVE: + Tcl_SetStringObj(resultPtr, "volumerelative", -1); + break; } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_mtime); - goto done; - case FILE_OWNED: + return TCL_OK; + } + case FILE_READABLE: { if (objc != 3) { - errorString = "owned name"; - goto not3Args; - } - statOp = 0; - break; + goto only3Args; + } + return CheckAccess(interp, objv[2], R_OK); + } case FILE_READLINK: { - char linkValue[MAXPATHLEN + 1]; - int linkLength; + char *fileName, *contents; + Tcl_DString name, link; if (objc != 3) { - errorString = "readlink name"; - goto not3Args; + goto only3Args; + } + + fileName = Tcl_GetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &name); + if (fileName == NULL) { + return TCL_ERROR; } /* @@ -1086,97 +1087,301 @@ checkAccess: */ #ifndef S_IFLNK - linkLength = -1; + contents = NULL; errno = EINVAL; #else - linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1); + contents = TclpReadlink(fileName, &link); #endif /* S_IFLNK */ - if (linkLength == -1) { - Tcl_AppendStringsToObj(resultPtr, "couldn't readlink \"", - Tcl_GetStringFromObj(objv[2], &length), "\": ", + + Tcl_DStringFree(&name); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not readlink \"", + Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; + return TCL_ERROR; } - linkValue[linkLength] = 0; - Tcl_SetStringObj(resultPtr, linkValue, linkLength); - goto done; + Tcl_DStringResult(interp, &link); + return TCL_OK; } - case FILE_SIZE: + case FILE_RENAME: { + int result; + char **argv; + + argv = StringifyObjects(objc, objv); + result = TclFileRenameCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_ROOTNAME: { + int length; + char *fileName, *extension; + if (objc != 3) { - errorString = "size name"; - goto not3Args; + goto only3Args; } - if (TclStat(fileName, &statBuf) == -1) { - goto badStat; + fileName = Tcl_GetStringFromObj(objv[2], &length); + extension = TclGetExtension(fileName); + if (extension == NULL) { + Tcl_SetObjResult(interp, objv[2]); + } else { + Tcl_SetStringObj(resultPtr, fileName, + (int) (length - strlen(extension))); } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_size); - goto done; - case FILE_STAT: + return TCL_OK; + } + case FILE_SIZE: { + struct stat buf; + + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetLongObj(resultPtr, (long) buf.st_size); + return TCL_OK; + } + case FILE_SPLIT: { + int i, argc; + char **argv; + char *fileName; + Tcl_Obj *objPtr; + + if (objc != 3) { + goto only3Args; + } + fileName = Tcl_GetString(objv[2]); + Tcl_SplitPath(fileName, &argc, &argv); + for (i = 0; i < argc; i++) { + objPtr = Tcl_NewStringObj(argv[i], -1); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); + } + ckfree((char *) argv); + return TCL_OK; + } + case FILE_STAT: { + char *varName; + struct stat buf; + if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); - result = TCL_ERROR; - goto done; + return TCL_ERROR; } - - if (TclStat(fileName, &statBuf) == -1) { -badStat: - Tcl_AppendStringsToObj(resultPtr, "couldn't stat \"", - Tcl_GetStringFromObj(objv[2], &length), - "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } - result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3], - &length), &statBuf); - goto done; - case FILE_TYPE: + varName = Tcl_GetString(objv[3]); + return StoreStatData(interp, varName, &buf); + } + case FILE_TAIL: { + int argc; + char **argv; + if (objc != 3) { - errorString = "type name"; - goto not3Args; + goto only3Args; } - if (lstat(fileName, &statBuf) == -1) { - goto badStat; + if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { + return TCL_ERROR; } - errorString = GetTypeFromMode((int) statBuf.st_mode); - Tcl_SetStringObj(resultPtr, errorString, -1); - goto done; - } - if (TclStat(fileName, &statBuf) == -1) { - Tcl_SetBooleanObj(resultPtr, 0); - goto done; - } - switch (statOp) { - case 0: /* - * For Windows and Macintosh, there are no user ids - * associated with a file, so we always return 1. + * Return the last component, unless it is the only component, + * and it is the root of an absolute path. */ -#if (defined(__WIN32__) || defined(MAC_TCL)) - mode = 1; -#else - mode = (geteuid() == statBuf.st_uid); -#endif - break; - case 1: - mode = S_ISREG(statBuf.st_mode); - break; - case 2: - mode = S_ISDIR(statBuf.st_mode); - break; + if (argc > 0) { + if ((argc > 1) + || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetStringObj(resultPtr, argv[argc - 1], -1); + } + } + ckfree((char *) argv); + return TCL_OK; + } + case FILE_TYPE: { + struct stat buf; + + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetStringObj(resultPtr, + GetTypeFromMode((unsigned short) buf.st_mode), -1); + return TCL_OK; + } + case FILE_VOLUMES: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + return TclpListVolumes(interp); + } + case FILE_WRITABLE: { + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], W_OK); + } } - Tcl_SetBooleanObj(resultPtr, mode); -done: - Tcl_DStringFree(&buffer); - return result; + only3Args: + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * SplitPath -- + * + * Utility procedure used by Tcl_FileObjCmd() to split a path. + * Differs from standard Tcl_SplitPath in its handling of home + * directories; Tcl_SplitPath preserves the "~" while this + * procedure computes the actual full path name. + * + * Results: + * The return value is TCL_OK if the path could be split, TCL_ERROR + * otherwise. If TCL_ERROR was returned, an error message is left + * in interp. If TCL_OK was returned, *argvPtr is set to a newly + * allocated array of strings that represent the individual + * directories in the specified path, and *argcPtr is filled with + * the length of that array. + * + * Side effects: + * Memory allocated. The caller must eventually free this memory + * by calling ckfree() on *argvPtr. + * + *--------------------------------------------------------------------------- + */ + +static int +SplitPath(interp, objPtr, argcPtr, argvPtr) + Tcl_Interp *interp; /* Interp for error return. May be NULL. */ + Tcl_Obj *objPtr; /* Path to be split. */ + int *argcPtr; /* Filled with length of following array. */ + char ***argvPtr; /* Filled with array of strings representing + * the elements of the specified path. */ +{ + char *fileName; + + fileName = Tcl_GetString(objPtr); + + /* + * If there is only one element, and it starts with a tilde, + * perform tilde substitution and resplit the path. + */ + + Tcl_SplitPath(fileName, argcPtr, argvPtr); + if ((*argcPtr == 1) && (fileName[0] == '~')) { + Tcl_DString ds; + + ckfree((char *) *argvPtr); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SplitPath(fileName, argcPtr, argvPtr); + Tcl_DStringFree(&ds); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * CheckAccess -- + * + * Utility procedure used by Tcl_FileObjCmd() to query file + * attributes available through the access() system call. + * + * Results: + * Always returns TCL_OK. Sets interp's result to boolean true or + * false depending on whether the file has the specified attribute. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +CheckAccess(interp, objPtr, mode) + Tcl_Interp *interp; /* Interp for status return. Must not be + * NULL. */ + Tcl_Obj *objPtr; /* Name of file to check. */ + int mode; /* Attribute to check; passed as argument to + * access(). */ +{ + int value; + char *fileName; + Tcl_DString ds; + + fileName = Tcl_GetString(objPtr); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + value = 0; + } else { + value = (TclAccess(fileName, mode) == 0); + Tcl_DStringFree(&ds); + } + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); -not3Args: - Tcl_WrongNumArgs(interp, 1, objv, errorString); - result = TCL_ERROR; - goto done; + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * GetStatBuf -- + * + * Utility procedure used by Tcl_FileObjCmd() to query file + * attributes available through the stat() or lstat() system call. + * + * Results: + * The return value is TCL_OK if the specified file exists and can + * be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an + * error message is left in interp's result. If TCL_OK is returned, + * *statPtr is filled with information about the specified file. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +GetStatBuf(interp, objPtr, statProc, statPtr) + Tcl_Interp *interp; /* Interp for error return. May be NULL. */ + Tcl_Obj *objPtr; /* Path name to examine. */ + StatProc *statProc; /* Either stat() or lstat() depending on + * desired behavior. */ + struct stat *statPtr; /* Filled with info about file obtained by + * calling (*statProc)(). */ +{ + char *fileName; + Tcl_DString ds; + int status; + + fileName = Tcl_GetString(objPtr); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + + status = (*statProc)(Tcl_DStringValue(&ds), statPtr); + Tcl_DStringFree(&ds); + + if (status < 0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "could not read \"", + Tcl_GetString(objPtr), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; } /* @@ -1190,7 +1395,7 @@ not3Args: * * Results: * Returns a standard Tcl return value. If an error occurs then - * a message is left in interp->result. + * a message is left in interp's result. * * Side effects: * Elements of the associative array given by "varName" are modified. @@ -1206,34 +1411,34 @@ StoreStatData(interp, varName, statPtr) struct stat *statPtr; /* Pointer to buffer containing * stat data to store in varName. */ { - char string[30]; + char string[TCL_INTEGER_SPACE]; - sprintf(string, "%ld", (long) statPtr->st_dev); + TclFormatInt(string, (long) statPtr->st_dev); if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_ino); + TclFormatInt(string, (long) statPtr->st_ino); if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_mode); + TclFormatInt(string, (unsigned short) statPtr->st_mode); if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_nlink); + TclFormatInt(string, (long) statPtr->st_nlink); if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_uid); + TclFormatInt(string, (long) statPtr->st_uid); if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_gid); + TclFormatInt(string, (long) statPtr->st_gid); if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; @@ -1243,24 +1448,24 @@ StoreStatData(interp, varName, statPtr) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_atime); + TclFormatInt(string, (long) statPtr->st_atime); if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_mtime); + TclFormatInt(string, (long) statPtr->st_mtime); if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_ctime); + TclFormatInt(string, (long) statPtr->st_ctime); if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } if (Tcl_SetVar2(interp, varName, "type", - GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) - == NULL) { + GetTypeFromMode((unsigned short) statPtr->st_mode), + TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } return TCL_OK; @@ -1312,7 +1517,7 @@ GetTypeFromMode(mode) /* *---------------------------------------------------------------------- * - * Tcl_ForCmd -- + * Tcl_FoObjCmd -- * * This procedure is invoked to process the "for" Tcl command. * See the user documentation for details on what it does. @@ -1333,21 +1538,20 @@ GetTypeFromMode(mode) /* ARGSUSED */ int -Tcl_ForCmd(dummy, interp, argc, argv) +Tcl_ForObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " start test next command\"", (char *) NULL); + if (objc != 5) { + Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } - result = Tcl_Eval(interp, argv[1]); + result = Tcl_EvalObjEx(interp, objv[1], 0); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); @@ -1355,23 +1559,24 @@ Tcl_ForCmd(dummy, interp, argc, argv) return result; } while (1) { - result = Tcl_ExprBoolean(interp, argv[2], &value); + result = Tcl_ExprBooleanObj(interp, objv[2], &value); if (result != TCL_OK) { return result; } if (!value) { break; } - result = Tcl_Eval(interp, argv[4]); + result = Tcl_EvalObjEx(interp, objv[4], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); Tcl_AddErrorInfo(interp, msg); } break; } - result = Tcl_Eval(interp, argv[3]); + result = Tcl_EvalObjEx(interp, objv[3], 0); if (result == TCL_BREAK) { break; } else if (result != TCL_OK) { @@ -1490,7 +1695,6 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) /* * Break up the value lists and variable lists into elements - * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. */ maxj = 0; @@ -1562,8 +1766,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) valuePtr = Tcl_NewObj(); /* empty string */ isEmptyObj = 1; } - varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL, - valuePtr, TCL_PARSE_PART1); + varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], + NULL, valuePtr, 0); if (varValuePtr == NULL) { if (isEmptyObj) { Tcl_DecrRefCount(valuePtr); @@ -1571,8 +1775,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't set loop variable: \"", - Tcl_GetStringFromObj(varvList[i][v], (int *) NULL), - "\"", (char *) NULL); + Tcl_GetString(varvList[i][v]), "\"", (char *) NULL); result = TCL_ERROR; goto done; } @@ -1580,7 +1783,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) } } - result = Tcl_EvalObj(interp, bodyPtr); + result = Tcl_EvalObjEx(interp, bodyPtr, 0); if (result != TCL_OK) { if (result == TCL_CONTINUE) { result = TCL_OK; @@ -1588,7 +1791,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) result = TCL_OK; break; } else if (result == TCL_ERROR) { - char msg[100]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"foreach\" body line %d)", interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); @@ -1643,10 +1847,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - register char *format; /* Used to read characters from the format + char *format; /* Used to read characters from the format * string. */ int formatLen; /* The length of the format string */ - char *endPtr; /* Points to the last char in format array */ + char *endPtr; /* Points to the last char in format array */ char newFormat[40]; /* A new format specifier is generated here. */ int width; /* Field width from field specifier, or 0 if * no width given. */ @@ -1666,8 +1870,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * sprintf, according to the following * definitions: */ # define INT_VALUE 0 -# define PTR_VALUE 1 -# define DOUBLE_VALUE 2 +# define CHAR_VALUE 1 +# define PTR_VALUE 2 +# define DOUBLE_VALUE 3 +# define STRING_VALUE 4 # define MAX_FLOAT_SIZE 320 Tcl_Obj *resultPtr; /* Where result is stored finally. */ @@ -1688,6 +1894,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * seen. */ int useShort; /* Value to be printed is short (half word). */ char *end; /* Used to locate end of numerical fields. */ + int stringLen = 0; /* Length of string in characters rather + * than bytes. Used for %s substitution. */ + int gotMinus; /* Non-zero indicates that a minus flag has + * been seen in the current field. */ + int gotPrecision; /* Non-zero indicates that a precision has + * been set for the current field. */ /* * This procedure is a bit nasty. The goal is to use sprintf to @@ -1695,7 +1907,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * 1. this procedure can't trust its arguments. * 2. we must be able to provide a large enough result area to hold * whatever's generated. This is hard to estimate. - * 2. there's no way to move the arguments from objv to the call + * 3. there's no way to move the arguments from objv to the call * to sprintf in a reasonable way. This is particularly nasty * because some of the arguments may be two-word values (doubles). * So, what happens here is to scan the format string one % group @@ -1703,12 +1915,11 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, - "formatString ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } - format = Tcl_GetStringFromObj(objv[1], &formatLen); + format = (char *) Tcl_GetStringFromObj(objv[1], &formatLen); endPtr = format + formatLen; resultPtr = Tcl_NewObj(); objIndex = 2; @@ -1717,6 +1928,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) register char *newPtr = newFormat; width = precision = noPercent = useShort = 0; + gotMinus = gotPrecision = 0; whichValue = PTR_VALUE; /* @@ -1748,7 +1960,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) *newPtr = '%'; newPtr++; format++; - if (isdigit(UCHAR(*format))) { + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ int tmp; /* @@ -1757,7 +1969,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * in the same format string. */ - tmp = strtoul(format, &end, 10); + tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; } @@ -1782,21 +1994,30 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) xpgCheckDone: while ((*format == '-') || (*format == '#') || (*format == '0') || (*format == ' ') || (*format == '+')) { + if (*format == '-') { + gotMinus = 1; + } *newPtr = *format; newPtr++; format++; } - if (isdigit(UCHAR(*format))) { - width = strtoul(format, &end, 10); + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ + width = strtoul(format, &end, 10); /* INTL: Tcl source. */ format = end; } else if (*format == '*') { if (objIndex >= objc) { goto badIndex; } - if (Tcl_GetIntFromObj(interp, objv[objIndex], - &width) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &width) != TCL_OK) { goto fmtError; } + if (width < 0) { + width = -width; + *newPtr = '-'; + gotMinus = 1; + newPtr++; + } objIndex++; format++; } @@ -1812,7 +2033,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) width = 0; } if (width != 0) { - TclFormatInt(newPtr, width); + TclFormatInt(newPtr, width); /* INTL: printf format. */ while (*newPtr != 0) { newPtr++; } @@ -1821,23 +2042,24 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) *newPtr = '.'; newPtr++; format++; + gotPrecision = 1; } - if (isdigit(UCHAR(*format))) { - precision = strtoul(format, &end, 10); + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ + precision = strtoul(format, &end, 10); /* INTL: "C" locale. */ format = end; } else if (*format == '*') { if (objIndex >= objc) { goto badIndex; } - if (Tcl_GetIntFromObj(interp, objv[objIndex], - &precision) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &precision) != TCL_OK) { goto fmtError; } objIndex++; format++; } - if (precision != 0) { - TclFormatInt(newPtr, precision); + if (gotPrecision) { + TclFormatInt(newPtr, precision); /* INTL: printf format. */ while (*newPtr != 0) { newPtr++; } @@ -1864,31 +2086,47 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) case 'u': case 'x': case 'X': - if (Tcl_GetIntFromObj(interp, objv[objIndex], - (int *) &intValue) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } whichValue = INT_VALUE; size = 40 + precision; break; case 's': + /* + * Compute the length of the string in characters and add + * any additional space required by the field width. All of + * the extra characters will be spaces, so one byte per + * character is adequate. + */ + + whichValue = STRING_VALUE; ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size); + stringLen = Tcl_NumUtfChars(ptrValue, size); + if (gotPrecision && (precision < stringLen)) { + stringLen = precision; + } + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; + if (width > stringLen) { + size += (width - stringLen); + } break; case 'c': - if (Tcl_GetIntFromObj(interp, objv[objIndex], - (int *) &intValue) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } - whichValue = INT_VALUE; - size = 1; + whichValue = CHAR_VALUE; + size = width + TCL_UTF_MAX; break; case 'e': case 'E': case 'f': case 'g': case 'G': - if (Tcl_GetDoubleFromObj(interp, objv[objIndex], - &doubleValue) != TCL_OK) { + if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &doubleValue) != TCL_OK) { goto fmtError; } whichValue = DOUBLE_VALUE; @@ -1902,13 +2140,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) "format string ended in middle of field specifier", TCL_STATIC); goto fmtError; - default: - { - char buf[40]; - sprintf(buf, "bad field specifier \"%c\"", *format); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - goto fmtError; - } + default: { + char buf[40]; + sprintf(buf, "bad field specifier \"%c\"", *format); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + goto fmtError; + } } objIndex++; format++; @@ -1932,17 +2169,68 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) dst = (char *) ckalloc((unsigned) (size + 1)); dstSize = size; } + switch (whichValue) { + case DOUBLE_VALUE: { + sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */ + break; + } + case INT_VALUE: { + if (useShort) { + sprintf(dst, newFormat, (short) intValue); + } else { + sprintf(dst, newFormat, intValue); + } + break; + } + case CHAR_VALUE: { + char *ptr; + ptr = dst; + if (!gotMinus) { + for ( ; --width > 0; ptr++) { + *ptr = ' '; + } + } + ptr += Tcl_UniCharToUtf(intValue, ptr); + for ( ; --width > 0; ptr++) { + *ptr = ' '; + } + *ptr = '\0'; + break; + } + case STRING_VALUE: { + char *ptr; + int pad; + + ptr = dst; + if (width > stringLen) { + pad = width - stringLen; + } else { + pad = 0; + } - if (whichValue == DOUBLE_VALUE) { - sprintf(dst, newFormat, doubleValue); - } else if (whichValue == INT_VALUE) { - if (useShort) { - sprintf(dst, newFormat, (short) intValue); - } else { - sprintf(dst, newFormat, intValue); + if (!gotMinus) { + while (pad > 0) { + *ptr++ = ' '; + pad--; + } + } + + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; + if (size) { + memcpy(ptr, ptrValue, (size_t) size); + ptr += size; + } + while (pad > 0) { + *ptr++ = ' '; + pad--; + } + *ptr = '\0'; + break; + } + default: { + sprintf(dst, newFormat, ptrValue); + break; } - } else { - sprintf(dst, newFormat, ptrValue); } Tcl_AppendToObj(resultPtr, dst, -1); } @@ -1975,3 +2263,43 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } + +/* + *--------------------------------------------------------------------------- + * + * StringifyObjects -- + * + * Helper function to bridge the gap between an object-based procedure + * and an older string-based procedure. + * + * Given an array of objects, allocate an array that consists of the + * string representations of those objects. + * + * Results: + * The return value is a pointer to the newly allocated array of + * strings. Elements 0 to (objc-1) of the string array point to the + * string representation of the corresponding element in the source + * object array; element objc of the string array is NULL. + * + * Side effects: + * Memory allocated. The caller must eventually free this memory + * by calling ckfree() on the return value. + * + *--------------------------------------------------------------------------- + */ + +static char ** +StringifyObjects(objc, objv) + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int i; + char **argv; + + argv = (char **) ckalloc((objc + 1) * sizeof(char *)); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[i] = NULL; + return argv; +} |