Parent Directory
| 
Revision Log
| 
Patch
| revision 64 by dashley, Sun Oct 30 04:21:11 2016 UTC | revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC | |
|---|---|---|
| # | Line 1 | Line 1 |
| /* $Header$ */ | ||
| /* | ||
| * tclCmdAH.c -- | ||
| * | ||
| * This file contains the top-level command routines for most of | ||
| * the Tcl built-in commands whose names begin with the letters | ||
| * A to H. | ||
| * | ||
| * 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. | ||
| * | ||
| * RCS: @(#) $Id: tclcmdah.c,v 1.1.1.1 2001/06/13 04:34:24 dtashley 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_BreakObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "break" 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 "break" or the name | ||
| * to which "break" was renamed: e.g., "set z break; $z" | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_BreakObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| if (objc != 1) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| return TCL_BREAK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_CaseObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "case" 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_CaseObjCmd(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 int i; | ||
| int body, result; | ||
| char *string, *arg; | ||
| int caseObjc; | ||
| Tcl_Obj *CONST *caseObjv; | ||
| Tcl_Obj *armPtr; | ||
| if (objc < 3) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, | ||
| "string ?in? patList body ... ?default body?"); | ||
| return TCL_ERROR; | ||
| } | ||
| string = Tcl_GetString(objv[1]); | ||
| body = -1; | ||
| arg = Tcl_GetString(objv[2]); | ||
| if (strcmp(arg, "in") == 0) { | ||
| i = 3; | ||
| } else { | ||
| i = 2; | ||
| } | ||
| caseObjc = objc - i; | ||
| caseObjv = objv + i; | ||
| /* | ||
| * If all of the pattern/command pairs are lumped into a single | ||
| * argument, split them out again. | ||
| */ | ||
| if (caseObjc == 1) { | ||
| Tcl_Obj **newObjv; | ||
| Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); | ||
| caseObjv = newObjv; | ||
| } | ||
| for (i = 0; i < caseObjc; i += 2) { | ||
| int patObjc, j; | ||
| char **patObjv; | ||
| char *pat; | ||
| unsigned char *p; | ||
| if (i == (caseObjc - 1)) { | ||
| Tcl_ResetResult(interp); | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| "extra case pattern with no body", -1); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Check for special case of single pattern (no list) with | ||
| * no backslash sequences. | ||
| */ | ||
| 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 ((*pat == 'd') && (strcmp(pat, "default") == 0)) { | ||
| body = i + 1; | ||
| } | ||
| if (Tcl_StringMatch(string, pat)) { | ||
| body = i + 1; | ||
| goto match; | ||
| } | ||
| continue; | ||
| } | ||
| /* | ||
| * Break up pattern lists, then check each of the patterns | ||
| * in the list. | ||
| */ | ||
| result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); | ||
| if (result != TCL_OK) { | ||
| return result; | ||
| } | ||
| for (j = 0; j < patObjc; j++) { | ||
| if (Tcl_StringMatch(string, patObjv[j])) { | ||
| body = i + 1; | ||
| break; | ||
| } | ||
| } | ||
| ckfree((char *) patObjv); | ||
| if (j < patObjc) { | ||
| break; | ||
| } | ||
| } | ||
| match: | ||
| if (body != -1) { | ||
| armPtr = caseObjv[body - 1]; | ||
| result = Tcl_EvalObjEx(interp, caseObjv[body], 0); | ||
| if (result == TCL_ERROR) { | ||
| char msg[100 + TCL_INTEGER_SPACE]; | ||
| arg = Tcl_GetString(armPtr); | ||
| sprintf(msg, | ||
| "\n (\"%.50s\" arm line %d)", arg, | ||
| interp->errorLine); | ||
| Tcl_AddObjErrorInfo(interp, msg, -1); | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| * Nothing matched: return nothing. | ||
| */ | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_CatchObjCmd -- | ||
| * | ||
| * This object-based procedure is invoked to process the "catch" 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_CatchObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| Tcl_Obj *varNamePtr = NULL; | ||
| int result; | ||
| if ((objc != 2) && (objc != 3)) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?"); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Save a pointer to the variable name object, if any, in case the | ||
| * Tcl_EvalObj reallocates the bytecode interpreter's evaluation | ||
| * stack rendering objv invalid. | ||
| */ | ||
| if (objc == 3) { | ||
| varNamePtr = objv[2]; | ||
| } | ||
| result = Tcl_EvalObjEx(interp, objv[1], 0); | ||
| if (objc == 3) { | ||
| if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, | ||
| Tcl_GetObjResult(interp), 0) == NULL) { | ||
| Tcl_ResetResult(interp); | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| "couldn't save command result in variable", -1); | ||
| return TCL_ERROR; | ||
| } | ||
| } | ||
| /* | ||
| * Set the interpreter's object result to an integer object holding the | ||
| * integer Tcl_EvalObj result. Note that we don't bother generating a | ||
| * string representation. We reset the interpreter's object result | ||
| * to an unshared empty object and then set it to be an integer object. | ||
| */ | ||
| Tcl_ResetResult(interp); | ||
| Tcl_SetIntObj(Tcl_GetObjResult(interp), result); | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_CdObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "cd" 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_CdObjCmd(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 *dirName; | ||
| Tcl_DString ds; | ||
| int result; | ||
| if (objc > 2) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "?dirName?"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (objc == 2) { | ||
| dirName = Tcl_GetString(objv[1]); | ||
| } else { | ||
| dirName = "~"; | ||
| } | ||
| if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| 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; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ConcatObjCmd -- | ||
| * | ||
| * This object-based procedure is invoked to process the "concat" 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_ConcatObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| if (objc >= 2) { | ||
| Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1)); | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ContinueObjCmd - | ||
| * | ||
| * This procedure is invoked to process the "continue" 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 "continue" or the name | ||
| * to which "continue" was renamed: e.g., "set z continue; $z" | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_ContinueObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| if (objc != 1) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| return TCL_CONTINUE; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * 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. | ||
| * 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_ErrorObjCmd(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; | ||
| char *info; | ||
| int infoLen; | ||
| if ((objc < 2) || (objc > 4)) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (objc >= 3) { /* process the optional info argument */ | ||
| info = Tcl_GetStringFromObj(objv[2], &infoLen); | ||
| if (*info != 0) { | ||
| Tcl_AddObjErrorInfo(interp, info, infoLen); | ||
| iPtr->flags |= ERR_ALREADY_LOGGED; | ||
| } | ||
| } | ||
| if (objc == 4) { | ||
| Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY); | ||
| iPtr->flags |= ERROR_CODE_SET; | ||
| } | ||
| Tcl_SetObjResult(interp, objv[1]); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_EvalObjCmd -- | ||
| * | ||
| * This object-based procedure is invoked to process the "eval" 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_EvalObjCmd(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 result; | ||
| register Tcl_Obj *objPtr; | ||
| if (objc < 2) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (objc == 2) { | ||
| result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT); | ||
| } else { | ||
| /* | ||
| * More than one argument: concatenate them together with spaces | ||
| * between, then evaluate the result. Tcl_EvalObjEx will delete | ||
| * the object when it decrements its refcount after eval'ing it. | ||
| */ | ||
| objPtr = Tcl_ConcatObj(objc-1, objv+1); | ||
| result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); | ||
| } | ||
| if (result == TCL_ERROR) { | ||
| char msg[32 + TCL_INTEGER_SPACE]; | ||
| sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); | ||
| Tcl_AddObjErrorInfo(interp, msg, -1); | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ExitObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "exit" 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_ExitObjCmd(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 value; | ||
| if ((objc != 1) && (objc != 2)) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (objc == 1) { | ||
| value = 0; | ||
| } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| Tcl_Exit(value); | ||
| /*NOTREACHED*/ | ||
| return TCL_OK; /* Better not ever reach this! */ | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ExprObjCmd -- | ||
| * | ||
| * This object-based procedure is invoked to process the "expr" Tcl | ||
| * command. See the user documentation for details on what it does. | ||
| * | ||
| * With the bytecode compiler, this procedure is called in two | ||
| * circumstances: 1) to execute expr commands that are too complicated | ||
| * or too unsafe to try compiling directly into an inline sequence of | ||
| * instructions, and 2) to execute commands where the command name is | ||
| * computed at runtime and is "expr" or the name to which "expr" was | ||
| * renamed (e.g., "set z expr; $z 2+3") | ||
| * | ||
| * Results: | ||
| * A standard Tcl object result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_ExprObjCmd(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; | ||
| Tcl_Obj *resultPtr; | ||
| register char *bytes; | ||
| int length, i, result; | ||
| if (objc < 2) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (objc == 2) { | ||
| result = Tcl_ExprObj(interp, objv[1], &resultPtr); | ||
| if (result == TCL_OK) { | ||
| Tcl_SetObjResult(interp, resultPtr); | ||
| Tcl_DecrRefCount(resultPtr); /* done with the result object */ | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| * Create a new object holding the concatenated argument strings. | ||
| */ | ||
| bytes = Tcl_GetStringFromObj(objv[1], &length); | ||
| objPtr = Tcl_NewStringObj(bytes, length); | ||
| Tcl_IncrRefCount(objPtr); | ||
| for (i = 2; i < objc; i++) { | ||
| Tcl_AppendToObj(objPtr, " ", 1); | ||
| bytes = Tcl_GetStringFromObj(objv[i], &length); | ||
| Tcl_AppendToObj(objPtr, bytes, length); | ||
| } | ||
| /* | ||
| * Evaluate the concatenated string object. | ||
| */ | ||
| result = Tcl_ExprObj(interp, objPtr, &resultPtr); | ||
| if (result == TCL_OK) { | ||
| Tcl_SetObjResult(interp, resultPtr); | ||
| Tcl_DecrRefCount(resultPtr); /* done with the result object */ | ||
| } | ||
| /* | ||
| * Free allocated resources. | ||
| */ | ||
| Tcl_DecrRefCount(objPtr); | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_FileObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "file" Tcl command. | ||
| * See the user documentation for details on what it does. | ||
| * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH | ||
| * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_FileObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| Tcl_Obj *resultPtr; | ||
| int index; | ||
| /* | ||
| * This list of constants should match the fileOption string array below. | ||
| */ | ||
| static char *fileOptions[] = { | ||
| "atime", "attributes", "channels", "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_CHANNELS, 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) { | ||
| return TCL_ERROR; | ||
| } | ||
| resultPtr = Tcl_GetObjResult(interp); | ||
| switch ((enum options) index) { | ||
| case FILE_ATIME: { | ||
| struct stat buf; | ||
| 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; | ||
| } | ||
| case FILE_ATTRIBUTES: { | ||
| return TclFileAttrsCmd(interp, objc, objv); | ||
| } | ||
| case FILE_CHANNELS: { | ||
| if ((objc < 2) || (objc > 3)) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); | ||
| return TCL_ERROR; | ||
| } | ||
| return Tcl_GetChannelNamesEx(interp, | ||
| ((objc == 2) ? NULL : Tcl_GetString(objv[2]))); | ||
| } | ||
| case FILE_COPY: { | ||
| int result; | ||
| char **argv; | ||
| argv = StringifyObjects(objc, objv); | ||
| result = TclFileCopyCmd(interp, objc, argv); | ||
| ckfree((char *) argv); | ||
| return result; | ||
| } | ||
| case FILE_DELETE: { | ||
| int result; | ||
| char **argv; | ||
| argv = StringifyObjects(objc, objv); | ||
| result = TclFileDeleteCmd(interp, objc, argv); | ||
| ckfree((char *) argv); | ||
| return result; | ||
| } | ||
| case FILE_DIRNAME: { | ||
| int argc; | ||
| char **argv; | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Return all but the last component. If there is only one | ||
| * component, return it if the path was non-relative, otherwise | ||
| * return the current directory. | ||
| */ | ||
| 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, argv[0], -1); | ||
| } | ||
| ckfree((char *) argv); | ||
| return TCL_OK; | ||
| } | ||
| case FILE_EXECUTABLE: { | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| return CheckAccess(interp, objv[2], X_OK); | ||
| } | ||
| case FILE_EXISTS: { | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| return CheckAccess(interp, objv[2], F_OK); | ||
| } | ||
| case FILE_EXTENSION: { | ||
| char *fileName, *extension; | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| fileName = Tcl_GetString(objv[2]); | ||
| extension = TclGetExtension(fileName); | ||
| if (extension != NULL) { | ||
| Tcl_SetStringObj(resultPtr, extension, -1); | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| case FILE_ISDIRECTORY: { | ||
| int value; | ||
| struct stat buf; | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| value = 0; | ||
| if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { | ||
| value = S_ISDIR(buf.st_mode); | ||
| } | ||
| Tcl_SetBooleanObj(resultPtr, value); | ||
| return TCL_OK; | ||
| } | ||
| case FILE_ISFILE: { | ||
| int value; | ||
| struct stat buf; | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| value = 0; | ||
| if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { | ||
| value = S_ISREG(buf.st_mode); | ||
| } | ||
| Tcl_SetBooleanObj(resultPtr, value); | ||
| return TCL_OK; | ||
| } | ||
| case FILE_JOIN: { | ||
| char **argv; | ||
| Tcl_DString ds; | ||
| if (objc < 3) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); | ||
| return TCL_ERROR; | ||
| } | ||
| 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_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; | ||
| } | ||
| varName = Tcl_GetString(objv[3]); | ||
| return StoreStatData(interp, varName, &buf); | ||
| } | ||
| case FILE_MTIME: { | ||
| struct stat buf; | ||
| 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; | ||
| } | ||
| case FILE_MKDIR: { | ||
| char **argv; | ||
| int result; | ||
| if (objc < 3) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); | ||
| return TCL_ERROR; | ||
| } | ||
| 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) { | ||
| goto only3Args; | ||
| } | ||
| fileName = Tcl_GetString(objv[2]); | ||
| fileName = Tcl_TranslateFileName(interp, fileName, &ds); | ||
| if (fileName == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds)); | ||
| Tcl_DStringFree(&ds); | ||
| return TCL_OK; | ||
| } | ||
| case FILE_OWNED: { | ||
| int value; | ||
| struct stat buf; | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| value = 0; | ||
| if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { | ||
| /* | ||
| * For Windows and Macintosh, there are no user ids | ||
| * associated with a file, so we always return 1. | ||
| */ | ||
| #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 (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| 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; | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| case FILE_READABLE: { | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| return CheckAccess(interp, objv[2], R_OK); | ||
| } | ||
| case FILE_READLINK: { | ||
| char *fileName, *contents; | ||
| Tcl_DString name, link; | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| fileName = Tcl_GetString(objv[2]); | ||
| fileName = Tcl_TranslateFileName(interp, fileName, &name); | ||
| if (fileName == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * If S_IFLNK isn't defined it means that the machine doesn't | ||
| * support symbolic links, so the file can't possibly be a | ||
| * symbolic link. Generate an EINVAL error, which is what | ||
| * happens on machines that do support symbolic links when | ||
| * you invoke readlink on a file that isn't a symbolic link. | ||
| */ | ||
| #ifndef S_IFLNK | ||
| contents = NULL; | ||
| errno = EINVAL; | ||
| #else | ||
| contents = TclpReadlink(fileName, &link); | ||
| #endif /* S_IFLNK */ | ||
| Tcl_DStringFree(&name); | ||
| if (contents == NULL) { | ||
| Tcl_AppendResult(interp, "could not readlink \"", | ||
| Tcl_GetString(objv[2]), "\": ", | ||
| Tcl_PosixError(interp), (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| Tcl_DStringResult(interp, &link); | ||
| return TCL_OK; | ||
| } | ||
| 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) { | ||
| goto only3Args; | ||
| } | ||
| 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))); | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| case FILE_SIZE: { | ||
| struct stat buf; | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| if (GetStatBuf(interp, objv[2], TclStat, &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"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| varName = Tcl_GetString(objv[3]); | ||
| return StoreStatData(interp, varName, &buf); | ||
| } | ||
| case FILE_TAIL: { | ||
| int argc; | ||
| char **argv; | ||
| if (objc != 3) { | ||
| goto only3Args; | ||
| } | ||
| if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Return the last component, unless it is the only component, | ||
| * and it is the root of an absolute path. | ||
| */ | ||
| 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); | ||
| } | ||
| } | ||
| 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); | ||
| 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; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * StoreStatData -- | ||
| * | ||
| * This is a utility procedure that breaks out the fields of a | ||
| * "stat" structure and stores them in textual form into the | ||
| * elements of an associative array. | ||
| * | ||
| * Results: | ||
| * Returns a standard Tcl return value. If an error occurs then | ||
| * a message is left in interp's result. | ||
| * | ||
| * Side effects: | ||
| * Elements of the associative array given by "varName" are modified. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| static int | ||
| StoreStatData(interp, varName, statPtr) | ||
| Tcl_Interp *interp; /* Interpreter for error reports. */ | ||
| char *varName; /* Name of associative array variable | ||
| * in which to store stat results. */ | ||
| struct stat *statPtr; /* Pointer to buffer containing | ||
| * stat data to store in varName. */ | ||
| { | ||
| char string[TCL_INTEGER_SPACE]; | ||
| TclFormatInt(string, (long) statPtr->st_dev); | ||
| if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) | ||
| == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| TclFormatInt(string, (long) statPtr->st_ino); | ||
| if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) | ||
| == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| TclFormatInt(string, (unsigned short) statPtr->st_mode); | ||
| if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) | ||
| == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| TclFormatInt(string, (long) statPtr->st_nlink); | ||
| if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) | ||
| == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| TclFormatInt(string, (long) statPtr->st_uid); | ||
| if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) | ||
| == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| TclFormatInt(string, (long) statPtr->st_gid); | ||
| if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) | ||
| == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| sprintf(string, "%lu", (unsigned long) statPtr->st_size); | ||
| if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) | ||
| == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| TclFormatInt(string, (long) statPtr->st_atime); | ||
| if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) | ||
| == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| TclFormatInt(string, (long) statPtr->st_mtime); | ||
| if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) | ||
| == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| 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((unsigned short) statPtr->st_mode), | ||
| TCL_LEAVE_ERR_MSG) == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * GetTypeFromMode -- | ||
| * | ||
| * Given a mode word, returns a string identifying the type of a | ||
| * file. | ||
| * | ||
| * Results: | ||
| * A static text string giving the file type from mode. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| static char * | ||
| GetTypeFromMode(mode) | ||
| int mode; | ||
| { | ||
| if (S_ISREG(mode)) { | ||
| return "file"; | ||
| } else if (S_ISDIR(mode)) { | ||
| return "directory"; | ||
| } else if (S_ISCHR(mode)) { | ||
| return "characterSpecial"; | ||
| } else if (S_ISBLK(mode)) { | ||
| return "blockSpecial"; | ||
| } else if (S_ISFIFO(mode)) { | ||
| return "fifo"; | ||
| #ifdef S_ISLNK | ||
| } else if (S_ISLNK(mode)) { | ||
| return "link"; | ||
| #endif | ||
| #ifdef S_ISSOCK | ||
| } else if (S_ISSOCK(mode)) { | ||
| return "socket"; | ||
| #endif | ||
| } | ||
| return "unknown"; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ForObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "for" 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 "for" or the name | ||
| * to which "for" was renamed: e.g., | ||
| * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}" | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_ForObjCmd(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 result, value; | ||
| if (objc != 5) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); | ||
| return TCL_ERROR; | ||
| } | ||
| result = Tcl_EvalObjEx(interp, objv[1], 0); | ||
| if (result != TCL_OK) { | ||
| if (result == TCL_ERROR) { | ||
| Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); | ||
| } | ||
| return result; | ||
| } | ||
| while (1) { | ||
| /* | ||
| * We need to reset the result before passing it off to | ||
| * Tcl_ExprBooleanObj. Otherwise, any error message will be appended | ||
| * to the result of the last evaluation. | ||
| */ | ||
| Tcl_ResetResult(interp); | ||
| result = Tcl_ExprBooleanObj(interp, objv[2], &value); | ||
| if (result != TCL_OK) { | ||
| return result; | ||
| } | ||
| if (!value) { | ||
| break; | ||
| } | ||
| result = Tcl_EvalObjEx(interp, objv[4], 0); | ||
| if ((result != TCL_OK) && (result != TCL_CONTINUE)) { | ||
| if (result == TCL_ERROR) { | ||
| char msg[32 + TCL_INTEGER_SPACE]; | ||
| sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); | ||
| Tcl_AddErrorInfo(interp, msg); | ||
| } | ||
| break; | ||
| } | ||
| result = Tcl_EvalObjEx(interp, objv[3], 0); | ||
| if (result == TCL_BREAK) { | ||
| break; | ||
| } else if (result != TCL_OK) { | ||
| if (result == TCL_ERROR) { | ||
| Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); | ||
| } | ||
| return result; | ||
| } | ||
| } | ||
| if (result == TCL_BREAK) { | ||
| result = TCL_OK; | ||
| } | ||
| if (result == TCL_OK) { | ||
| Tcl_ResetResult(interp); | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ForeachObjCmd -- | ||
| * | ||
| * This object-based procedure is invoked to process the "foreach" 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_ForeachObjCmd(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 result = TCL_OK; | ||
| int i; /* i selects a value list */ | ||
| int j, maxj; /* Number of loop iterations */ | ||
| int v; /* v selects a loop variable */ | ||
| int numLists; /* Count of value lists */ | ||
| Tcl_Obj *bodyPtr; | ||
| /* | ||
| * We copy the argument object pointers into a local array to avoid | ||
| * the problem that "objv" might become invalid. It is a pointer into | ||
| * the evaluation stack and that stack might be grown and reallocated | ||
| * if the loop body requires a large amount of stack space. | ||
| */ | ||
| #define NUM_ARGS 9 | ||
| Tcl_Obj *(argObjStorage[NUM_ARGS]); | ||
| Tcl_Obj **argObjv = argObjStorage; | ||
| #define STATIC_LIST_SIZE 4 | ||
| int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */ | ||
| int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */ | ||
| Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */ | ||
| int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */ | ||
| Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */ | ||
| int *index = indexArray; | ||
| int *varcList = varcListArray; | ||
| Tcl_Obj ***varvList = varvListArray; | ||
| int *argcList = argcListArray; | ||
| Tcl_Obj ***argvList = argvListArray; | ||
| if (objc < 4 || (objc%2 != 0)) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, | ||
| "varList list ?varList list ...? command"); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Create the object argument array "argObjv". Make sure argObjv is | ||
| * large enough to hold the objc arguments. | ||
| */ | ||
| if (objc > NUM_ARGS) { | ||
| argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *)); | ||
| } | ||
| for (i = 0; i < objc; i++) { | ||
| argObjv[i] = objv[i]; | ||
| } | ||
| /* | ||
| * Manage numList parallel value lists. | ||
| * argvList[i] is a value list counted by argcList[i] | ||
| * varvList[i] is the list of variables associated with the value list | ||
| * varcList[i] is the number of variables associated with the value list | ||
| * index[i] is the current pointer into the value list argvList[i] | ||
| */ | ||
| numLists = (objc-2)/2; | ||
| if (numLists > STATIC_LIST_SIZE) { | ||
| index = (int *) ckalloc(numLists * sizeof(int)); | ||
| varcList = (int *) ckalloc(numLists * sizeof(int)); | ||
| varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); | ||
| argcList = (int *) ckalloc(numLists * sizeof(int)); | ||
| argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); | ||
| } | ||
| for (i = 0; i < numLists; i++) { | ||
| index[i] = 0; | ||
| varcList[i] = 0; | ||
| varvList[i] = (Tcl_Obj **) NULL; | ||
| argcList[i] = 0; | ||
| argvList[i] = (Tcl_Obj **) NULL; | ||
| } | ||
| /* | ||
| * Break up the value lists and variable lists into elements | ||
| */ | ||
| maxj = 0; | ||
| for (i = 0; i < numLists; i++) { | ||
| result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], | ||
| &varcList[i], &varvList[i]); | ||
| if (result != TCL_OK) { | ||
| goto done; | ||
| } | ||
| if (varcList[i] < 1) { | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| "foreach varlist is empty", -1); | ||
| result = TCL_ERROR; | ||
| goto done; | ||
| } | ||
| result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], | ||
| &argcList[i], &argvList[i]); | ||
| if (result != TCL_OK) { | ||
| goto done; | ||
| } | ||
| j = argcList[i] / varcList[i]; | ||
| if ((argcList[i] % varcList[i]) != 0) { | ||
| j++; | ||
| } | ||
| if (j > maxj) { | ||
| maxj = j; | ||
| } | ||
| } | ||
| /* | ||
| * Iterate maxj times through the lists in parallel | ||
| * If some value lists run out of values, set loop vars to "" | ||
| */ | ||
| bodyPtr = argObjv[objc-1]; | ||
| for (j = 0; j < maxj; j++) { | ||
| for (i = 0; i < numLists; i++) { | ||
| /* | ||
| * If a variable or value list object has been converted to | ||
| * another kind of Tcl object, convert it back to a list object | ||
| * and refetch the pointer to its element array. | ||
| */ | ||
| if (argObjv[1+i*2]->typePtr != &tclListType) { | ||
| result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], | ||
| &varcList[i], &varvList[i]); | ||
| if (result != TCL_OK) { | ||
| panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i); | ||
| } | ||
| } | ||
| if (argObjv[2+i*2]->typePtr != &tclListType) { | ||
| result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], | ||
| &argcList[i], &argvList[i]); | ||
| if (result != TCL_OK) { | ||
| panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i); | ||
| } | ||
| } | ||
| for (v = 0; v < varcList[i]; v++) { | ||
| int k = index[i]++; | ||
| Tcl_Obj *valuePtr, *varValuePtr; | ||
| int isEmptyObj = 0; | ||
| if (k < argcList[i]) { | ||
| valuePtr = argvList[i][k]; | ||
| } else { | ||
| valuePtr = Tcl_NewObj(); /* empty string */ | ||
| isEmptyObj = 1; | ||
| } | ||
| varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], | ||
| NULL, valuePtr, 0); | ||
| if (varValuePtr == NULL) { | ||
| if (isEmptyObj) { | ||
| Tcl_DecrRefCount(valuePtr); | ||
| } | ||
| Tcl_ResetResult(interp); | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "couldn't set loop variable: \"", | ||
| Tcl_GetString(varvList[i][v]), "\"", (char *) NULL); | ||
| result = TCL_ERROR; | ||
| goto done; | ||
| } | ||
| } | ||
| } | ||
| result = Tcl_EvalObjEx(interp, bodyPtr, 0); | ||
| if (result != TCL_OK) { | ||
| if (result == TCL_CONTINUE) { | ||
| result = TCL_OK; | ||
| } else if (result == TCL_BREAK) { | ||
| result = TCL_OK; | ||
| break; | ||
| } else if (result == TCL_ERROR) { | ||
| char msg[32 + TCL_INTEGER_SPACE]; | ||
| sprintf(msg, "\n (\"foreach\" body line %d)", | ||
| interp->errorLine); | ||
| Tcl_AddObjErrorInfo(interp, msg, -1); | ||
| break; | ||
| } else { | ||
| break; | ||
| } | ||
| } | ||
| } | ||
| if (result == TCL_OK) { | ||
| Tcl_ResetResult(interp); | ||
| } | ||
| done: | ||
| if (numLists > STATIC_LIST_SIZE) { | ||
| ckfree((char *) index); | ||
| ckfree((char *) varcList); | ||
| ckfree((char *) argcList); | ||
| ckfree((char *) varvList); | ||
| ckfree((char *) argvList); | ||
| } | ||
| if (argObjv != argObjStorage) { | ||
| ckfree((char *) argObjv); | ||
| } | ||
| return result; | ||
| #undef STATIC_LIST_SIZE | ||
| #undef NUM_ARGS | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_FormatObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "format" 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_FormatObjCmd(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 *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 newFormat[40]; /* A new format specifier is generated here. */ | ||
| int width; /* Field width from field specifier, or 0 if | ||
| * no width given. */ | ||
| int precision; /* Field precision from field specifier, or 0 | ||
| * if no precision given. */ | ||
| int size; /* Number of bytes needed for result of | ||
| * conversion, based on type of conversion | ||
| * ("e", "s", etc.), width, and precision. */ | ||
| int intValue; /* Used to hold value to pass to sprintf, if | ||
| * it's a one-word integer or char value */ | ||
| char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if | ||
| * it's a one-word value. */ | ||
| double doubleValue; /* Used to hold value to pass to sprintf if | ||
| * it's a double value. */ | ||
| int whichValue; /* Indicates which of intValue, ptrValue, | ||
| * or doubleValue has the value to pass to | ||
| * sprintf, according to the following | ||
| * definitions: */ | ||
| # define INT_VALUE 0 | ||
| # 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. */ | ||
| char staticBuf[MAX_FLOAT_SIZE + 1]; | ||
| /* A static buffer to copy the format results | ||
| * into */ | ||
| char *dst = staticBuf; /* The buffer that sprintf writes into each | ||
| * time the format processes a specifier */ | ||
| int dstSize = MAX_FLOAT_SIZE; | ||
| /* The size of the dst buffer */ | ||
| int noPercent; /* Special case for speed: indicates there's | ||
| * no field specifier, just a string to copy.*/ | ||
| int objIndex; /* Index of argument to substitute next. */ | ||
| int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style | ||
| * specifier has been seen. */ | ||
| int gotSequential = 0; /* Non-zero means that a regular sequential | ||
| * (non-XPG3) conversion specifier has been | ||
| * 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. */ | ||
| int gotZero; /* Non-zero indicates that a zero flag has | ||
| * been seen in the current field. */ | ||
| /* | ||
| * This procedure is a bit nasty. The goal is to use sprintf to | ||
| * do most of the dirty work. There are several problems: | ||
| * 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. | ||
| * 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 | ||
| * at a time, making many individual calls to sprintf. | ||
| */ | ||
| if (objc < 2) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?"); | ||
| return TCL_ERROR; | ||
| } | ||
| format = (char *) Tcl_GetStringFromObj(objv[1], &formatLen); | ||
| endPtr = format + formatLen; | ||
| resultPtr = Tcl_NewObj(); | ||
| objIndex = 2; | ||
| while (format < endPtr) { | ||
| register char *newPtr = newFormat; | ||
| width = precision = noPercent = useShort = 0; | ||
| gotZero = gotMinus = gotPrecision = 0; | ||
| whichValue = PTR_VALUE; | ||
| /* | ||
| * Get rid of any characters before the next field specifier. | ||
| */ | ||
| if (*format != '%') { | ||
| ptrValue = format; | ||
| while ((*format != '%') && (format < endPtr)) { | ||
| format++; | ||
| } | ||
| size = format - ptrValue; | ||
| noPercent = 1; | ||
| goto doField; | ||
| } | ||
| if (format[1] == '%') { | ||
| ptrValue = format; | ||
| size = 1; | ||
| noPercent = 1; | ||
| format += 2; | ||
| goto doField; | ||
| } | ||
| /* | ||
| * Parse off a field specifier, compute how many characters | ||
| * will be needed to store the result, and substitute for | ||
| * "*" size specifiers. | ||
| */ | ||
| *newPtr = '%'; | ||
| newPtr++; | ||
| format++; | ||
| if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ | ||
| int tmp; | ||
| /* | ||
| * Check for an XPG3-style %n$ specification. Note: there | ||
| * must not be a mixture of XPG3 specs and non-XPG3 specs | ||
| * in the same format string. | ||
| */ | ||
| tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */ | ||
| if (*end != '$') { | ||
| goto notXpg; | ||
| } | ||
| format = end+1; | ||
| gotXpg = 1; | ||
| if (gotSequential) { | ||
| goto mixedXPG; | ||
| } | ||
| objIndex = tmp+1; | ||
| if ((objIndex < 2) || (objIndex >= objc)) { | ||
| goto badIndex; | ||
| } | ||
| goto xpgCheckDone; | ||
| } | ||
| notXpg: | ||
| gotSequential = 1; | ||
| if (gotXpg) { | ||
| goto mixedXPG; | ||
| } | ||
| xpgCheckDone: | ||
| while ((*format == '-') || (*format == '#') || (*format == '0') | ||
| || (*format == ' ') || (*format == '+')) { | ||
| if (*format == '-') { | ||
| gotMinus = 1; | ||
| } | ||
| if (*format == '0') { | ||
| /* | ||
| * This will be handled by sprintf for numbers, but we | ||
| * need to do the char/string ones ourselves | ||
| */ | ||
| gotZero = 1; | ||
| } | ||
| *newPtr = *format; | ||
| newPtr++; | ||
| format++; | ||
| } | ||
| 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, /* INTL: Tcl source. */ | ||
| objv[objIndex], &width) != TCL_OK) { | ||
| goto fmtError; | ||
| } | ||
| if (width < 0) { | ||
| width = -width; | ||
| *newPtr = '-'; | ||
| gotMinus = 1; | ||
| newPtr++; | ||
| } | ||
| objIndex++; | ||
| format++; | ||
| } | ||
| if (width > 100000) { | ||
| /* | ||
| * Don't allow arbitrarily large widths: could cause core | ||
| * dump when we try to allocate a zillion bytes of memory | ||
| * below. | ||
| */ | ||
| width = 100000; | ||
| } else if (width < 0) { | ||
| width = 0; | ||
| } | ||
| if (width != 0) { | ||
| TclFormatInt(newPtr, width); /* INTL: printf format. */ | ||
| while (*newPtr != 0) { | ||
| newPtr++; | ||
| } | ||
| } | ||
| if (*format == '.') { | ||
| *newPtr = '.'; | ||
| newPtr++; | ||
| format++; | ||
| gotPrecision = 1; | ||
| } | ||
| 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, /* INTL: Tcl source. */ | ||
| objv[objIndex], &precision) != TCL_OK) { | ||
| goto fmtError; | ||
| } | ||
| objIndex++; | ||
| format++; | ||
| } | ||
| if (gotPrecision) { | ||
| TclFormatInt(newPtr, precision); /* INTL: printf format. */ | ||
| while (*newPtr != 0) { | ||
| newPtr++; | ||
| } | ||
| } | ||
| if (*format == 'l') { | ||
| format++; | ||
| } else if (*format == 'h') { | ||
| useShort = 1; | ||
| *newPtr = 'h'; | ||
| newPtr++; | ||
| format++; | ||
| } | ||
| *newPtr = *format; | ||
| newPtr++; | ||
| *newPtr = 0; | ||
| if (objIndex >= objc) { | ||
| goto badIndex; | ||
| } | ||
| switch (*format) { | ||
| case 'i': | ||
| newPtr[-1] = 'd'; | ||
| case 'd': | ||
| case 'o': | ||
| case 'u': | ||
| case 'x': | ||
| case 'X': | ||
| 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, /* INTL: Tcl source. */ | ||
| objv[objIndex], &intValue) != TCL_OK) { | ||
| goto fmtError; | ||
| } | ||
| whichValue = CHAR_VALUE; | ||
| size = width + TCL_UTF_MAX; | ||
| break; | ||
| case 'e': | ||
| case 'E': | ||
| case 'f': | ||
| case 'g': | ||
| case 'G': | ||
| if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ | ||
| objv[objIndex], &doubleValue) != TCL_OK) { | ||
| goto fmtError; | ||
| } | ||
| whichValue = DOUBLE_VALUE; | ||
| size = MAX_FLOAT_SIZE; | ||
| if (precision > 10) { | ||
| size += precision; | ||
| } | ||
| break; | ||
| case 0: | ||
| Tcl_SetResult(interp, | ||
| "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; | ||
| } | ||
| } | ||
| objIndex++; | ||
| format++; | ||
| /* | ||
| * Make sure that there's enough space to hold the formatted | ||
| * result, then format it. | ||
| */ | ||
| doField: | ||
| if (width > size) { | ||
| size = width; | ||
| } | ||
| if (noPercent) { | ||
| Tcl_AppendToObj(resultPtr, ptrValue, size); | ||
| } else { | ||
| if (size > dstSize) { | ||
| if (dst != staticBuf) { | ||
| ckfree(dst); | ||
| } | ||
| 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; | ||
| char padChar = (gotZero ? '0' : ' '); | ||
| ptr = dst; | ||
| if (!gotMinus) { | ||
| for ( ; --width > 0; ptr++) { | ||
| *ptr = padChar; | ||
| } | ||
| } | ||
| ptr += Tcl_UniCharToUtf(intValue, ptr); | ||
| for ( ; --width > 0; ptr++) { | ||
| *ptr = padChar; | ||
| } | ||
| *ptr = '\0'; | ||
| break; | ||
| } | ||
| case STRING_VALUE: { | ||
| char *ptr; | ||
| char padChar = (gotZero ? '0' : ' '); | ||
| int pad; | ||
| ptr = dst; | ||
| if (width > stringLen) { | ||
| pad = width - stringLen; | ||
| } else { | ||
| pad = 0; | ||
| } | ||
| if (!gotMinus) { | ||
| while (pad > 0) { | ||
| *ptr++ = padChar; | ||
| pad--; | ||
| } | ||
| } | ||
| size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; | ||
| if (size) { | ||
| memcpy(ptr, ptrValue, (size_t) size); | ||
| ptr += size; | ||
| } | ||
| while (pad > 0) { | ||
| *ptr++ = padChar; | ||
| pad--; | ||
| } | ||
| *ptr = '\0'; | ||
| break; | ||
| } | ||
| default: { | ||
| sprintf(dst, newFormat, ptrValue); | ||
| break; | ||
| } | ||
| } | ||
| Tcl_AppendToObj(resultPtr, dst, -1); | ||
| } | ||
| } | ||
| Tcl_SetObjResult(interp, resultPtr); | ||
| if(dst != staticBuf) { | ||
| ckfree(dst); | ||
| } | ||
| return TCL_OK; | ||
| mixedXPG: | ||
| Tcl_SetResult(interp, | ||
| "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); | ||
| goto fmtError; | ||
| badIndex: | ||
| if (gotXpg) { | ||
| Tcl_SetResult(interp, | ||
| "\"%n$\" argument index out of range", TCL_STATIC); | ||
| } else { | ||
| Tcl_SetResult(interp, | ||
| "not enough arguments for all format specifiers", TCL_STATIC); | ||
| } | ||
| fmtError: | ||
| if(dst != staticBuf) { | ||
| ckfree(dst); | ||
| } | ||
| 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; | ||
| } | ||
| /* $History: tclcmdah.c $ | ||
| * | ||
| * ***************** Version 1 ***************** | ||
| * User: Dtashley Date: 1/02/01 Time: 1:28a | ||
| * Created in $/IjuScripter, IjuConsole/Source/Tcl Base | ||
| * Initial check-in. | ||
| */ | ||
| /* End of TCLCMDAH.C */ | ||
| 1 | /* $Header$ */ | |
| 2 | /* | |
| 3 | * tclCmdAH.c -- | |
| 4 | * | |
| 5 | * This file contains the top-level command routines for most of | |
| 6 | * the Tcl built-in commands whose names begin with the letters | |
| 7 | * A to H. | |
| 8 | * | |
| 9 | * Copyright (c) 1987-1993 The Regents of the University of California. | |
| 10 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. | |
| 11 | * | |
| 12 | * See the file "license.terms" for information on usage and redistribution | |
| 13 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
| 14 | * | |
| 15 | * RCS: @(#) $Id: tclcmdah.c,v 1.1.1.1 2001/06/13 04:34:24 dtashley Exp $ | |
| 16 | */ | |
| 17 | ||
| 18 | #include "tclInt.h" | |
| 19 | #include "tclPort.h" | |
| 20 | #include <locale.h> | |
| 21 | ||
| 22 | typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf)); | |
| 23 | ||
| 24 | /* | |
| 25 | * Prototypes for local procedures defined in this file: | |
| 26 | */ | |
| 27 | ||
| 28 | static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp, | |
| 29 | Tcl_Obj *objPtr, int mode)); | |
| 30 | static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, | |
| 31 | Tcl_Obj *objPtr, StatProc *statProc, | |
| 32 | struct stat *statPtr)); | |
| 33 | static char * GetTypeFromMode _ANSI_ARGS_((int mode)); | |
| 34 | static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp, | |
| 35 | Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr)); | |
| 36 | static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, | |
| 37 | char *varName, struct stat *statPtr)); | |
| 38 | static char ** StringifyObjects _ANSI_ARGS_((int objc, | |
| 39 | Tcl_Obj *CONST objv[])); | |
| 40 | ||
| 41 | /* | |
| 42 | *---------------------------------------------------------------------- | |
| 43 | * | |
| 44 | * Tcl_BreakObjCmd -- | |
| 45 | * | |
| 46 | * This procedure is invoked to process the "break" Tcl command. | |
| 47 | * See the user documentation for details on what it does. | |
| 48 | * | |
| 49 | * With the bytecode compiler, this procedure is only called when | |
| 50 | * a command name is computed at runtime, and is "break" or the name | |
| 51 | * to which "break" was renamed: e.g., "set z break; $z" | |
| 52 | * | |
| 53 | * Results: | |
| 54 | * A standard Tcl result. | |
| 55 | * | |
| 56 | * Side effects: | |
| 57 | * See the user documentation. | |
| 58 | * | |
| 59 | *---------------------------------------------------------------------- | |
| 60 | */ | |
| 61 | ||
| 62 | /* ARGSUSED */ | |
| 63 | int | |
| 64 | Tcl_BreakObjCmd(dummy, interp, objc, objv) | |
| 65 | ClientData dummy; /* Not used. */ | |
| 66 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 67 | int objc; /* Number of arguments. */ | |
| 68 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 69 | { | |
| 70 | if (objc != 1) { | |
| 71 | Tcl_WrongNumArgs(interp, 1, objv, NULL); | |
| 72 | return TCL_ERROR; | |
| 73 | } | |
| 74 | return TCL_BREAK; | |
| 75 | } | |
| 76 | ||
| 77 | /* | |
| 78 | *---------------------------------------------------------------------- | |
| 79 | * | |
| 80 | * Tcl_CaseObjCmd -- | |
| 81 | * | |
| 82 | * This procedure is invoked to process the "case" Tcl command. | |
| 83 | * See the user documentation for details on what it does. | |
| 84 | * | |
| 85 | * Results: | |
| 86 | * A standard Tcl object result. | |
| 87 | * | |
| 88 | * Side effects: | |
| 89 | * See the user documentation. | |
| 90 | * | |
| 91 | *---------------------------------------------------------------------- | |
| 92 | */ | |
| 93 | ||
| 94 | /* ARGSUSED */ | |
| 95 | int | |
| 96 | Tcl_CaseObjCmd(dummy, interp, objc, objv) | |
| 97 | ClientData dummy; /* Not used. */ | |
| 98 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 99 | int objc; /* Number of arguments. */ | |
| 100 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 101 | { | |
| 102 | register int i; | |
| 103 | int body, result; | |
| 104 | char *string, *arg; | |
| 105 | int caseObjc; | |
| 106 | Tcl_Obj *CONST *caseObjv; | |
| 107 | Tcl_Obj *armPtr; | |
| 108 | ||
| 109 | if (objc < 3) { | |
| 110 | Tcl_WrongNumArgs(interp, 1, objv, | |
| 111 | "string ?in? patList body ... ?default body?"); | |
| 112 | return TCL_ERROR; | |
| 113 | } | |
| 114 | ||
| 115 | string = Tcl_GetString(objv[1]); | |
| 116 | body = -1; | |
| 117 | ||
| 118 | arg = Tcl_GetString(objv[2]); | |
| 119 | if (strcmp(arg, "in") == 0) { | |
| 120 | i = 3; | |
| 121 | } else { | |
| 122 | i = 2; | |
| 123 | } | |
| 124 | caseObjc = objc - i; | |
| 125 | caseObjv = objv + i; | |
| 126 | ||
| 127 | /* | |
| 128 | * If all of the pattern/command pairs are lumped into a single | |
| 129 | * argument, split them out again. | |
| 130 | */ | |
| 131 | ||
| 132 | if (caseObjc == 1) { | |
| 133 | Tcl_Obj **newObjv; | |
| 134 | ||
| 135 | Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); | |
| 136 | caseObjv = newObjv; | |
| 137 | } | |
| 138 | ||
| 139 | for (i = 0; i < caseObjc; i += 2) { | |
| 140 | int patObjc, j; | |
| 141 | char **patObjv; | |
| 142 | char *pat; | |
| 143 | unsigned char *p; | |
| 144 | ||
| 145 | if (i == (caseObjc - 1)) { | |
| 146 | Tcl_ResetResult(interp); | |
| 147 | Tcl_AppendToObj(Tcl_GetObjResult(interp), | |
| 148 | "extra case pattern with no body", -1); | |
| 149 | return TCL_ERROR; | |
| 150 | } | |
| 151 | ||
| 152 | /* | |
| 153 | * Check for special case of single pattern (no list) with | |
| 154 | * no backslash sequences. | |
| 155 | */ | |
| 156 | ||
| 157 | pat = Tcl_GetString(caseObjv[i]); | |
| 158 | for (p = (unsigned char *) pat; *p != '\0'; p++) { | |
| 159 | if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ | |
| 160 | break; | |
| 161 | } | |
| 162 | } | |
| 163 | if (*p == '\0') { | |
| 164 | if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { | |
| 165 | body = i + 1; | |
| 166 | } | |
| 167 | if (Tcl_StringMatch(string, pat)) { | |
| 168 | body = i + 1; | |
| 169 | goto match; | |
| 170 | } | |
| 171 | continue; | |
| 172 | } | |
| 173 | ||
| 174 | ||
| 175 | /* | |
| 176 | * Break up pattern lists, then check each of the patterns | |
| 177 | * in the list. | |
| 178 | */ | |
| 179 | ||
| 180 | result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); | |
| 181 | if (result != TCL_OK) { | |
| 182 | return result; | |
| 183 | } | |
| 184 | for (j = 0; j < patObjc; j++) { | |
| 185 | if (Tcl_StringMatch(string, patObjv[j])) { | |
| 186 | body = i + 1; | |
| 187 | break; | |
| 188 | } | |
| 189 | } | |
| 190 | ckfree((char *) patObjv); | |
| 191 | if (j < patObjc) { | |
| 192 | break; | |
| 193 | } | |
| 194 | } | |
| 195 | ||
| 196 | match: | |
| 197 | if (body != -1) { | |
| 198 | armPtr = caseObjv[body - 1]; | |
| 199 | result = Tcl_EvalObjEx(interp, caseObjv[body], 0); | |
| 200 | if (result == TCL_ERROR) { | |
| 201 | char msg[100 + TCL_INTEGER_SPACE]; | |
| 202 | ||
| 203 | arg = Tcl_GetString(armPtr); | |
| 204 | sprintf(msg, | |
| 205 | "\n (\"%.50s\" arm line %d)", arg, | |
| 206 | interp->errorLine); | |
| 207 | Tcl_AddObjErrorInfo(interp, msg, -1); | |
| 208 | } | |
| 209 | return result; | |
| 210 | } | |
| 211 | ||
| 212 | /* | |
| 213 | * Nothing matched: return nothing. | |
| 214 | */ | |
| 215 | ||
| 216 | return TCL_OK; | |
| 217 | } | |
| 218 | ||
| 219 | /* | |
| 220 | *---------------------------------------------------------------------- | |
| 221 | * | |
| 222 | * Tcl_CatchObjCmd -- | |
| 223 | * | |
| 224 | * This object-based procedure is invoked to process the "catch" Tcl | |
| 225 | * command. See the user documentation for details on what it does. | |
| 226 | * | |
| 227 | * Results: | |
| 228 | * A standard Tcl object result. | |
| 229 | * | |
| 230 | * Side effects: | |
| 231 | * See the user documentation. | |
| 232 | * | |
| 233 | *---------------------------------------------------------------------- | |
| 234 | */ | |
| 235 | ||
| 236 | /* ARGSUSED */ | |
| 237 | int | |
| 238 | Tcl_CatchObjCmd(dummy, interp, objc, objv) | |
| 239 | ClientData dummy; /* Not used. */ | |
| 240 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 241 | int objc; /* Number of arguments. */ | |
| 242 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 243 | { | |
| 244 | Tcl_Obj *varNamePtr = NULL; | |
| 245 | int result; | |
| 246 | ||
| 247 | if ((objc != 2) && (objc != 3)) { | |
| 248 | Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?"); | |
| 249 | return TCL_ERROR; | |
| 250 | } | |
| 251 | ||
| 252 | /* | |
| 253 | * Save a pointer to the variable name object, if any, in case the | |
| 254 | * Tcl_EvalObj reallocates the bytecode interpreter's evaluation | |
| 255 | * stack rendering objv invalid. | |
| 256 | */ | |
| 257 | ||
| 258 | if (objc == 3) { | |
| 259 | varNamePtr = objv[2]; | |
| 260 | } | |
| 261 | ||
| 262 | result = Tcl_EvalObjEx(interp, objv[1], 0); | |
| 263 | ||
| 264 | if (objc == 3) { | |
| 265 | if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, | |
| 266 | Tcl_GetObjResult(interp), 0) == NULL) { | |
| 267 | Tcl_ResetResult(interp); | |
| 268 | Tcl_AppendToObj(Tcl_GetObjResult(interp), | |
| 269 | "couldn't save command result in variable", -1); | |
| 270 | return TCL_ERROR; | |
| 271 | } | |
| 272 | } | |
| 273 | ||
| 274 | /* | |
| 275 | * Set the interpreter's object result to an integer object holding the | |
| 276 | * integer Tcl_EvalObj result. Note that we don't bother generating a | |
| 277 | * string representation. We reset the interpreter's object result | |
| 278 | * to an unshared empty object and then set it to be an integer object. | |
| 279 | */ | |
| 280 | ||
| 281 | Tcl_ResetResult(interp); | |
| 282 | Tcl_SetIntObj(Tcl_GetObjResult(interp), result); | |
| 283 | return TCL_OK; | |
| 284 | } | |
| 285 | ||
| 286 | /* | |
| 287 | *---------------------------------------------------------------------- | |
| 288 | * | |
| 289 | * Tcl_CdObjCmd -- | |
| 290 | * | |
| 291 | * This procedure is invoked to process the "cd" Tcl command. | |
| 292 | * See the user documentation for details on what it does. | |
| 293 | * | |
| 294 | * Results: | |
| 295 | * A standard Tcl result. | |
| 296 | * | |
| 297 | * Side effects: | |
| 298 | * See the user documentation. | |
| 299 | * | |
| 300 | *---------------------------------------------------------------------- | |
| 301 | */ | |
| 302 | ||
| 303 | /* ARGSUSED */ | |
| 304 | int | |
| 305 | Tcl_CdObjCmd(dummy, interp, objc, objv) | |
| 306 | ClientData dummy; /* Not used. */ | |
| 307 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 308 | int objc; /* Number of arguments. */ | |
| 309 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 310 | { | |
| 311 | char *dirName; | |
| 312 | Tcl_DString ds; | |
| 313 | int result; | |
| 314 | ||
| 315 | if (objc > 2) { | |
| 316 | Tcl_WrongNumArgs(interp, 1, objv, "?dirName?"); | |
| 317 | return TCL_ERROR; | |
| 318 | } | |
| 319 | ||
| 320 | if (objc == 2) { | |
| 321 | dirName = Tcl_GetString(objv[1]); | |
| 322 | } else { | |
| 323 | dirName = "~"; | |
| 324 | } | |
| 325 | if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) { | |
| 326 | return TCL_ERROR; | |
| 327 | } | |
| 328 | ||
| 329 | result = Tcl_Chdir(Tcl_DStringValue(&ds)); | |
| 330 | Tcl_DStringFree(&ds); | |
| 331 | ||
| 332 | if (result != 0) { | |
| 333 | Tcl_AppendResult(interp, "couldn't change working directory to \"", | |
| 334 | dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); | |
| 335 | return TCL_ERROR; | |
| 336 | } | |
| 337 | return TCL_OK; | |
| 338 | } | |
| 339 | ||
| 340 | /* | |
| 341 | *---------------------------------------------------------------------- | |
| 342 | * | |
| 343 | * Tcl_ConcatObjCmd -- | |
| 344 | * | |
| 345 | * This object-based procedure is invoked to process the "concat" Tcl | |
| 346 | * command. See the user documentation for details on what it does. | |
| 347 | * | |
| 348 | * Results: | |
| 349 | * A standard Tcl object result. | |
| 350 | * | |
| 351 | * Side effects: | |
| 352 | * See the user documentation. | |
| 353 | * | |
| 354 | *---------------------------------------------------------------------- | |
| 355 | */ | |
| 356 | ||
| 357 | /* ARGSUSED */ | |
| 358 | int | |
| 359 | Tcl_ConcatObjCmd(dummy, interp, objc, objv) | |
| 360 | ClientData dummy; /* Not used. */ | |
| 361 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 362 | int objc; /* Number of arguments. */ | |
| 363 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 364 | { | |
| 365 | if (objc >= 2) { | |
| 366 | Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1)); | |
| 367 | } | |
| 368 | return TCL_OK; | |
| 369 | } | |
| 370 | ||
| 371 | /* | |
| 372 | *---------------------------------------------------------------------- | |
| 373 | * | |
| 374 | * Tcl_ContinueObjCmd - | |
| 375 | * | |
| 376 | * This procedure is invoked to process the "continue" Tcl command. | |
| 377 | * See the user documentation for details on what it does. | |
| 378 | * | |
| 379 | * With the bytecode compiler, this procedure is only called when | |
| 380 | * a command name is computed at runtime, and is "continue" or the name | |
| 381 | * to which "continue" was renamed: e.g., "set z continue; $z" | |
| 382 | * | |
| 383 | * Results: | |
| 384 | * A standard Tcl result. | |
| 385 | * | |
| 386 | * Side effects: | |
| 387 | * See the user documentation. | |
| 388 | * | |
| 389 | *---------------------------------------------------------------------- | |
| 390 | */ | |
| 391 | ||
| 392 | /* ARGSUSED */ | |
| 393 | int | |
| 394 | Tcl_ContinueObjCmd(dummy, interp, objc, objv) | |
| 395 | ClientData dummy; /* Not used. */ | |
| 396 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 397 | int objc; /* Number of arguments. */ | |
| 398 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 399 | { | |
| 400 | if (objc != 1) { | |
| 401 | Tcl_WrongNumArgs(interp, 1, objv, NULL); | |
| 402 | return TCL_ERROR; | |
| 403 | } | |
| 404 | return TCL_CONTINUE; | |
| 405 | } | |
| 406 | ||
| 407 | /* | |
| 408 | *---------------------------------------------------------------------- | |
| 409 | * | |
| 410 | * Tcl_EncodingObjCmd -- | |
| 411 | * | |
| 412 | * This command manipulates encodings. | |
| 413 | * | |
| 414 | * Results: | |
| 415 | * A standard Tcl result. | |
| 416 | * | |
| 417 | * Side effects: | |
| 418 | * See the user documentation. | |
| 419 | * | |
| 420 | *---------------------------------------------------------------------- | |
| 421 | */ | |
| 422 | ||
| 423 | int | |
| 424 | Tcl_EncodingObjCmd(dummy, interp, objc, objv) | |
| 425 | ClientData dummy; /* Not used. */ | |
| 426 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 427 | int objc; /* Number of arguments. */ | |
| 428 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 429 | { | |
| 430 | int index, length; | |
| 431 | Tcl_Encoding encoding; | |
| 432 | char *string; | |
| 433 | Tcl_DString ds; | |
| 434 | Tcl_Obj *resultPtr; | |
| 435 | ||
| 436 | static char *optionStrings[] = { | |
| 437 | "convertfrom", "convertto", "names", "system", | |
| 438 | NULL | |
| 439 | }; | |
| 440 | enum options { | |
| 441 | ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM | |
| 442 | }; | |
| 443 | ||
| 444 | if (objc < 2) { | |
| 445 | Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); | |
| 446 | return TCL_ERROR; | |
| 447 | } | |
| 448 | if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, | |
| 449 | &index) != TCL_OK) { | |
| 450 | return TCL_ERROR; | |
| 451 | } | |
| 452 | ||
| 453 | switch ((enum options) index) { | |
| 454 | case ENC_CONVERTTO: | |
| 455 | case ENC_CONVERTFROM: { | |
| 456 | char *name; | |
| 457 | Tcl_Obj *data; | |
| 458 | if (objc == 3) { | |
| 459 | name = NULL; | |
| 460 | data = objv[2]; | |
| 461 | } else if (objc == 4) { | |
| 462 | name = Tcl_GetString(objv[2]); | |
| 463 | data = objv[3]; | |
| 464 | } else { | |
| 465 | Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); | |
| 466 | return TCL_ERROR; | |
| 467 | } | |
| 468 | ||
| 469 | encoding = Tcl_GetEncoding(interp, name); | |
| 470 | if (!encoding) { | |
| 471 | return TCL_ERROR; | |
| 472 | } | |
| 473 | ||
| 474 | if ((enum options) index == ENC_CONVERTFROM) { | |
| 475 | /* | |
| 476 | * Treat the string as binary data. | |
| 477 | */ | |
| 478 | ||
| 479 | string = (char *) Tcl_GetByteArrayFromObj(data, &length); | |
| 480 | Tcl_ExternalToUtfDString(encoding, string, length, &ds); | |
| 481 | ||
| 482 | /* | |
| 483 | * Note that we cannot use Tcl_DStringResult here because | |
| 484 | * it will truncate the string at the first null byte. | |
| 485 | */ | |
| 486 | ||
| 487 | Tcl_SetStringObj(Tcl_GetObjResult(interp), | |
| 488 | Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); | |
| 489 | Tcl_DStringFree(&ds); | |
| 490 | } else { | |
| 491 | /* | |
| 492 | * Store the result as binary data. | |
| 493 | */ | |
| 494 | ||
| 495 | string = Tcl_GetStringFromObj(data, &length); | |
| 496 | Tcl_UtfToExternalDString(encoding, string, length, &ds); | |
| 497 | resultPtr = Tcl_GetObjResult(interp); | |
| 498 | Tcl_SetByteArrayObj(resultPtr, | |
| 499 | (unsigned char *) Tcl_DStringValue(&ds), | |
| 500 | Tcl_DStringLength(&ds)); | |
| 501 | Tcl_DStringFree(&ds); | |
| 502 | } | |
| 503 | ||
| 504 | Tcl_FreeEncoding(encoding); | |
| 505 | break; | |
| 506 | } | |
| 507 | case ENC_NAMES: { | |
| 508 | if (objc > 2) { | |
| 509 | Tcl_WrongNumArgs(interp, 2, objv, NULL); | |
| 510 | return TCL_ERROR; | |
| 511 | } | |
| 512 | Tcl_GetEncodingNames(interp); | |
| 513 | break; | |
| 514 | } | |
| 515 | case ENC_SYSTEM: { | |
| 516 | if (objc > 3) { | |
| 517 | Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); | |
| 518 | return TCL_ERROR; | |
| 519 | } | |
| 520 | if (objc == 2) { | |
| 521 | Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC); | |
| 522 | } else { | |
| 523 | return Tcl_SetSystemEncoding(interp, | |
| 524 | Tcl_GetStringFromObj(objv[2], NULL)); | |
| 525 | } | |
| 526 | break; | |
| 527 | } | |
| 528 | } | |
| 529 | return TCL_OK; | |
| 530 | } | |
| 531 | ||
| 532 | /* | |
| 533 | *---------------------------------------------------------------------- | |
| 534 | * | |
| 535 | * Tcl_ErrorObjCmd -- | |
| 536 | * | |
| 537 | * This procedure is invoked to process the "error" Tcl command. | |
| 538 | * See the user documentation for details on what it does. | |
| 539 | * | |
| 540 | * Results: | |
| 541 | * A standard Tcl object result. | |
| 542 | * | |
| 543 | * Side effects: | |
| 544 | * See the user documentation. | |
| 545 | * | |
| 546 | *---------------------------------------------------------------------- | |
| 547 | */ | |
| 548 | ||
| 549 | /* ARGSUSED */ | |
| 550 | int | |
| 551 | Tcl_ErrorObjCmd(dummy, interp, objc, objv) | |
| 552 | ClientData dummy; /* Not used. */ | |
| 553 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 554 | int objc; /* Number of arguments. */ | |
| 555 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 556 | { | |
| 557 | Interp *iPtr = (Interp *) interp; | |
| 558 | char *info; | |
| 559 | int infoLen; | |
| 560 | ||
| 561 | if ((objc < 2) || (objc > 4)) { | |
| 562 | Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?"); | |
| 563 | return TCL_ERROR; | |
| 564 | } | |
| 565 | ||
| 566 | if (objc >= 3) { /* process the optional info argument */ | |
| 567 | info = Tcl_GetStringFromObj(objv[2], &infoLen); | |
| 568 | if (*info != 0) { | |
| 569 | Tcl_AddObjErrorInfo(interp, info, infoLen); | |
| 570 | iPtr->flags |= ERR_ALREADY_LOGGED; | |
| 571 | } | |
| 572 | } | |
| 573 | ||
| 574 | if (objc == 4) { | |
| 575 | Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY); | |
| 576 | iPtr->flags |= ERROR_CODE_SET; | |
| 577 | } | |
| 578 | ||
| 579 | Tcl_SetObjResult(interp, objv[1]); | |
| 580 | return TCL_ERROR; | |
| 581 | } | |
| 582 | ||
| 583 | /* | |
| 584 | *---------------------------------------------------------------------- | |
| 585 | * | |
| 586 | * Tcl_EvalObjCmd -- | |
| 587 | * | |
| 588 | * This object-based procedure is invoked to process the "eval" Tcl | |
| 589 | * command. See the user documentation for details on what it does. | |
| 590 | * | |
| 591 | * Results: | |
| 592 | * A standard Tcl object result. | |
| 593 | * | |
| 594 | * Side effects: | |
| 595 | * See the user documentation. | |
| 596 | * | |
| 597 | *---------------------------------------------------------------------- | |
| 598 | */ | |
| 599 | ||
| 600 | /* ARGSUSED */ | |
| 601 | int | |
| 602 | Tcl_EvalObjCmd(dummy, interp, objc, objv) | |
| 603 | ClientData dummy; /* Not used. */ | |
| 604 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 605 | int objc; /* Number of arguments. */ | |
| 606 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 607 | { | |
| 608 | int result; | |
| 609 | register Tcl_Obj *objPtr; | |
| 610 | ||
| 611 | if (objc < 2) { | |
| 612 | Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); | |
| 613 | return TCL_ERROR; | |
| 614 | } | |
| 615 | ||
| 616 | if (objc == 2) { | |
| 617 | result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT); | |
| 618 | } else { | |
| 619 | /* | |
| 620 | * More than one argument: concatenate them together with spaces | |
| 621 | * between, then evaluate the result. Tcl_EvalObjEx will delete | |
| 622 | * the object when it decrements its refcount after eval'ing it. | |
| 623 | */ | |
| 624 | objPtr = Tcl_ConcatObj(objc-1, objv+1); | |
| 625 | result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); | |
| 626 | } | |
| 627 | if (result == TCL_ERROR) { | |
| 628 | char msg[32 + TCL_INTEGER_SPACE]; | |
| 629 | ||
| 630 | sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); | |
| 631 | Tcl_AddObjErrorInfo(interp, msg, -1); | |
| 632 | } | |
| 633 | return result; | |
| 634 | } | |
| 635 | ||
| 636 | /* | |
| 637 | *---------------------------------------------------------------------- | |
| 638 | * | |
| 639 | * Tcl_ExitObjCmd -- | |
| 640 | * | |
| 641 | * This procedure is invoked to process the "exit" Tcl command. | |
| 642 | * See the user documentation for details on what it does. | |
| 643 | * | |
| 644 | * Results: | |
| 645 | * A standard Tcl object result. | |
| 646 | * | |
| 647 | * Side effects: | |
| 648 | * See the user documentation. | |
| 649 | * | |
| 650 | *---------------------------------------------------------------------- | |
| 651 | */ | |
| 652 | ||
| 653 | /* ARGSUSED */ | |
| 654 | int | |
| 655 | Tcl_ExitObjCmd(dummy, interp, objc, objv) | |
| 656 | ClientData dummy; /* Not used. */ | |
| 657 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 658 | int objc; /* Number of arguments. */ | |
| 659 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 660 | { | |
| 661 | int value; | |
| 662 | ||
| 663 | if ((objc != 1) && (objc != 2)) { | |
| 664 | Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); | |
| 665 | return TCL_ERROR; | |
| 666 | } | |
| 667 | ||
| 668 | if (objc == 1) { | |
| 669 | value = 0; | |
| 670 | } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { | |
| 671 | return TCL_ERROR; | |
| 672 | } | |
| 673 | Tcl_Exit(value); | |
| 674 | /*NOTREACHED*/ | |
| 675 | return TCL_OK; /* Better not ever reach this! */ | |
| 676 | } | |
| 677 | ||
| 678 | /* | |
| 679 | *---------------------------------------------------------------------- | |
| 680 | * | |
| 681 | * Tcl_ExprObjCmd -- | |
| 682 | * | |
| 683 | * This object-based procedure is invoked to process the "expr" Tcl | |
| 684 | * command. See the user documentation for details on what it does. | |
| 685 | * | |
| 686 | * With the bytecode compiler, this procedure is called in two | |
| 687 | * circumstances: 1) to execute expr commands that are too complicated | |
| 688 | * or too unsafe to try compiling directly into an inline sequence of | |
| 689 | * instructions, and 2) to execute commands where the command name is | |
| 690 | * computed at runtime and is "expr" or the name to which "expr" was | |
| 691 | * renamed (e.g., "set z expr; $z 2+3") | |
| 692 | * | |
| 693 | * Results: | |
| 694 | * A standard Tcl object result. | |
| 695 | * | |
| 696 | * Side effects: | |
| 697 | * See the user documentation. | |
| 698 | * | |
| 699 | *---------------------------------------------------------------------- | |
| 700 | */ | |
| 701 | ||
| 702 | /* ARGSUSED */ | |
| 703 | int | |
| 704 | Tcl_ExprObjCmd(dummy, interp, objc, objv) | |
| 705 | ClientData dummy; /* Not used. */ | |
| 706 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 707 | int objc; /* Number of arguments. */ | |
| 708 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 709 | { | |
| 710 | register Tcl_Obj *objPtr; | |
| 711 | Tcl_Obj *resultPtr; | |
| 712 | register char *bytes; | |
| 713 | int length, i, result; | |
| 714 | ||
| 715 | if (objc < 2) { | |
| 716 | Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); | |
| 717 | return TCL_ERROR; | |
| 718 | } | |
| 719 | ||
| 720 | if (objc == 2) { | |
| 721 | result = Tcl_ExprObj(interp, objv[1], &resultPtr); | |
| 722 | if (result == TCL_OK) { | |
| 723 | Tcl_SetObjResult(interp, resultPtr); | |
| 724 | Tcl_DecrRefCount(resultPtr); /* done with the result object */ | |
| 725 | } | |
| 726 | return result; | |
| 727 | } | |
| 728 | ||
| 729 | /* | |
| 730 | * Create a new object holding the concatenated argument strings. | |
| 731 | */ | |
| 732 | ||
| 733 | bytes = Tcl_GetStringFromObj(objv[1], &length); | |
| 734 | objPtr = Tcl_NewStringObj(bytes, length); | |
| 735 | Tcl_IncrRefCount(objPtr); | |
| 736 | for (i = 2; i < objc; i++) { | |
| 737 | Tcl_AppendToObj(objPtr, " ", 1); | |
| 738 | bytes = Tcl_GetStringFromObj(objv[i], &length); | |
| 739 | Tcl_AppendToObj(objPtr, bytes, length); | |
| 740 | } | |
| 741 | ||
| 742 | /* | |
| 743 | * Evaluate the concatenated string object. | |
| 744 | */ | |
| 745 | ||
| 746 | result = Tcl_ExprObj(interp, objPtr, &resultPtr); | |
| 747 | if (result == TCL_OK) { | |
| 748 | Tcl_SetObjResult(interp, resultPtr); | |
| 749 | Tcl_DecrRefCount(resultPtr); /* done with the result object */ | |
| 750 | } | |
| 751 | ||
| 752 | /* | |
| 753 | * Free allocated resources. | |
| 754 | */ | |
| 755 | ||
| 756 | Tcl_DecrRefCount(objPtr); | |
| 757 | return result; | |
| 758 | } | |
| 759 | ||
| 760 | /* | |
| 761 | *---------------------------------------------------------------------- | |
| 762 | * | |
| 763 | * Tcl_FileObjCmd -- | |
| 764 | * | |
| 765 | * This procedure is invoked to process the "file" Tcl command. | |
| 766 | * See the user documentation for details on what it does. | |
| 767 | * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH | |
| 768 | * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC. | |
| 769 | * | |
| 770 | * Results: | |
| 771 | * A standard Tcl result. | |
| 772 | * | |
| 773 | * Side effects: | |
| 774 | * See the user documentation. | |
| 775 | * | |
| 776 | *---------------------------------------------------------------------- | |
| 777 | */ | |
| 778 | ||
| 779 | /* ARGSUSED */ | |
| 780 | int | |
| 781 | Tcl_FileObjCmd(dummy, interp, objc, objv) | |
| 782 | ClientData dummy; /* Not used. */ | |
| 783 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 784 | int objc; /* Number of arguments. */ | |
| 785 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 786 | { | |
| 787 | Tcl_Obj *resultPtr; | |
| 788 | int index; | |
| 789 | ||
| 790 | /* | |
| 791 | * This list of constants should match the fileOption string array below. | |
| 792 | */ | |
| 793 | ||
| 794 | static char *fileOptions[] = { | |
| 795 | "atime", "attributes", "channels", "copy", | |
| 796 | "delete", | |
| 797 | "dirname", "executable", "exists", "extension", | |
| 798 | "isdirectory", "isfile", "join", "lstat", | |
| 799 | "mtime", "mkdir", "nativename", "owned", | |
| 800 | "pathtype", "readable", "readlink", "rename", | |
| 801 | "rootname", "size", "split", "stat", | |
| 802 | "tail", "type", "volumes", "writable", | |
| 803 | (char *) NULL | |
| 804 | }; | |
| 805 | enum options { | |
| 806 | FILE_ATIME, FILE_ATTRIBUTES, FILE_CHANNELS, FILE_COPY, | |
| 807 | FILE_DELETE, | |
| 808 | FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, | |
| 809 | FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT, | |
| 810 | FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED, | |
| 811 | FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME, | |
| 812 | FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT, | |
| 813 | FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE | |
| 814 | }; | |
| 815 | ||
| 816 | if (objc < 2) { | |
| 817 | Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); | |
| 818 | return TCL_ERROR; | |
| 819 | } | |
| 820 | if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, | |
| 821 | &index) != TCL_OK) { | |
| 822 | return TCL_ERROR; | |
| 823 | } | |
| 824 | ||
| 825 | resultPtr = Tcl_GetObjResult(interp); | |
| 826 | switch ((enum options) index) { | |
| 827 | case FILE_ATIME: { | |
| 828 | struct stat buf; | |
| 829 | char *fileName; | |
| 830 | struct utimbuf tval; | |
| 831 | ||
| 832 | if ((objc < 3) || (objc > 4)) { | |
| 833 | Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); | |
| 834 | return TCL_ERROR; | |
| 835 | } | |
| 836 | if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { | |
| 837 | return TCL_ERROR; | |
| 838 | } | |
| 839 | if (objc == 4) { | |
| 840 | if (Tcl_GetLongFromObj(interp, objv[3], | |
| 841 | (long*)(&buf.st_atime)) != TCL_OK) { | |
| 842 | return TCL_ERROR; | |
| 843 | } | |
| 844 | tval.actime = buf.st_atime; | |
| 845 | tval.modtime = buf.st_mtime; | |
| 846 | fileName = Tcl_GetString(objv[2]); | |
| 847 | if (utime(fileName, &tval) != 0) { | |
| 848 | Tcl_AppendStringsToObj(resultPtr, | |
| 849 | "could not set access time for file \"", | |
| 850 | fileName, "\": ", | |
| 851 | Tcl_PosixError(interp), (char *) NULL); | |
| 852 | return TCL_ERROR; | |
| 853 | } | |
| 854 | /* | |
| 855 | * Do another stat to ensure that the we return the | |
| 856 | * new recognized atime - hopefully the same as the | |
| 857 | * one we sent in. However, fs's like FAT don't | |
| 858 | * even know what atime is. | |
| 859 | */ | |
| 860 | if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { | |
| 861 | return TCL_ERROR; | |
| 862 | } | |
| 863 | } | |
| 864 | Tcl_SetLongObj(resultPtr, (long) buf.st_atime); | |
| 865 | return TCL_OK; | |
| 866 | } | |
| 867 | case FILE_ATTRIBUTES: { | |
| 868 | return TclFileAttrsCmd(interp, objc, objv); | |
| 869 | } | |
| 870 | case FILE_CHANNELS: { | |
| 871 | if ((objc < 2) || (objc > 3)) { | |
| 872 | Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); | |
| 873 | return TCL_ERROR; | |
| 874 | } | |
| 875 | return Tcl_GetChannelNamesEx(interp, | |
| 876 | ((objc == 2) ? NULL : Tcl_GetString(objv[2]))); | |
| 877 | } | |
| 878 | case FILE_COPY: { | |
| 879 | int result; | |
| 880 | char **argv; | |
| 881 | ||
| 882 | argv = StringifyObjects(objc, objv); | |
| 883 | result = TclFileCopyCmd(interp, objc, argv); | |
| 884 | ckfree((char *) argv); | |
| 885 | return result; | |
| 886 | } | |
| 887 | case FILE_DELETE: { | |
| 888 | int result; | |
| 889 | char **argv; | |
| 890 | ||
| 891 | argv = StringifyObjects(objc, objv); | |
| 892 | result = TclFileDeleteCmd(interp, objc, argv); | |
| 893 | ckfree((char *) argv); | |
| 894 | return result; | |
| 895 | } | |
| 896 | case FILE_DIRNAME: { | |
| 897 | int argc; | |
| 898 | char **argv; | |
| 899 | ||
| 900 | if (objc != 3) { | |
| 901 | goto only3Args; | |
| 902 | } | |
| 903 | if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { | |
| 904 | return TCL_ERROR; | |
| 905 | } | |
| 906 | ||
| 907 | /* | |
| 908 | * Return all but the last component. If there is only one | |
| 909 | * component, return it if the path was non-relative, otherwise | |
| 910 | * return the current directory. | |
| 911 | */ | |
| 912 | ||
| 913 | if (argc > 1) { | |
| 914 | Tcl_DString ds; | |
| 915 | ||
| 916 | Tcl_DStringInit(&ds); | |
| 917 | Tcl_JoinPath(argc - 1, argv, &ds); | |
| 918 | Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), | |
| 919 | Tcl_DStringLength(&ds)); | |
| 920 | Tcl_DStringFree(&ds); | |
| 921 | } else if ((argc == 0) | |
| 922 | || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { | |
| 923 | Tcl_SetStringObj(resultPtr, | |
| 924 | ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1); | |
| 925 | } else { | |
| 926 | Tcl_SetStringObj(resultPtr, argv[0], -1); | |
| 927 | } | |
| 928 | ckfree((char *) argv); | |
| 929 | return TCL_OK; | |
| 930 | } | |
| 931 | case FILE_EXECUTABLE: { | |
| 932 | if (objc != 3) { | |
| 933 | goto only3Args; | |
| 934 | } | |
| 935 | return CheckAccess(interp, objv[2], X_OK); | |
| 936 | } | |
| 937 | case FILE_EXISTS: { | |
| 938 | if (objc != 3) { | |
| 939 | goto only3Args; | |
| 940 | } | |
| 941 | return CheckAccess(interp, objv[2], F_OK); | |
| 942 | } | |
| 943 | case FILE_EXTENSION: { | |
| 944 | char *fileName, *extension; | |
| 945 | if (objc != 3) { | |
| 946 | goto only3Args; | |
| 947 | } | |
| 948 | fileName = Tcl_GetString(objv[2]); | |
| 949 | extension = TclGetExtension(fileName); | |
| 950 | if (extension != NULL) { | |
| 951 | Tcl_SetStringObj(resultPtr, extension, -1); | |
| 952 | } | |
| 953 | return TCL_OK; | |
| 954 | } | |
| 955 | case FILE_ISDIRECTORY: { | |
| 956 | int value; | |
| 957 | struct stat buf; | |
| 958 | ||
| 959 | if (objc != 3) { | |
| 960 | goto only3Args; | |
| 961 | } | |
| 962 | value = 0; | |
| 963 | if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { | |
| 964 | value = S_ISDIR(buf.st_mode); | |
| 965 | } | |
| 966 | Tcl_SetBooleanObj(resultPtr, value); | |
| 967 | return TCL_OK; | |
| 968 | } | |
| 969 | case FILE_ISFILE: { | |
| 970 | int value; | |
| 971 | struct stat buf; | |
| 972 | ||
| 973 | if (objc != 3) { | |
| 974 | goto only3Args; | |
| 975 | } | |
| 976 | value = 0; | |
| 977 | if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { | |
| 978 | value = S_ISREG(buf.st_mode); | |
| 979 | } | |
| 980 | Tcl_SetBooleanObj(resultPtr, value); | |
| 981 | return TCL_OK; | |
| 982 | } | |
| 983 | case FILE_JOIN: { | |
| 984 | char **argv; | |
| 985 | Tcl_DString ds; | |
| 986 | ||
| 987 | if (objc < 3) { | |
| 988 | Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); | |
| 989 | return TCL_ERROR; | |
| 990 | } | |
| 991 | argv = StringifyObjects(objc - 2, objv + 2); | |
| 992 | Tcl_DStringInit(&ds); | |
| 993 | Tcl_JoinPath(objc - 2, argv, &ds); | |
| 994 | Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), | |
| 995 | Tcl_DStringLength(&ds)); | |
| 996 | Tcl_DStringFree(&ds); | |
| 997 | ckfree((char *) argv); | |
| 998 | return TCL_OK; | |
| 999 | } | |
| 1000 | case FILE_LSTAT: { | |
| 1001 | char *varName; | |
| 1002 | struct stat buf; | |
| 1003 | ||
| 1004 | if (objc != 4) { | |
| 1005 | Tcl_WrongNumArgs(interp, 2, objv, "name varName"); | |
| 1006 | return TCL_ERROR; | |
| 1007 | } | |
| 1008 | if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { | |
| 1009 | return TCL_ERROR; | |
| 1010 | } | |
| 1011 | varName = Tcl_GetString(objv[3]); | |
| 1012 | return StoreStatData(interp, varName, &buf); | |
| 1013 | } | |
| 1014 | case FILE_MTIME: { | |
| 1015 | struct stat buf; | |
| 1016 | char *fileName; | |
| 1017 | struct utimbuf tval; | |
| 1018 | ||
| 1019 | if ((objc < 3) || (objc > 4)) { | |
| 1020 | Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); | |
| 1021 | return TCL_ERROR; | |
| 1022 | } | |
| 1023 | if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { | |
| 1024 | return TCL_ERROR; | |
| 1025 | } | |
| 1026 | if (objc == 4) { | |
| 1027 | if (Tcl_GetLongFromObj(interp, objv[3], | |
| 1028 | (long*)(&buf.st_mtime)) != TCL_OK) { | |
| 1029 | return TCL_ERROR; | |
| 1030 | } | |
| 1031 | tval.actime = buf.st_atime; | |
| 1032 | tval.modtime = buf.st_mtime; | |
| 1033 | fileName = Tcl_GetString(objv[2]); | |
| 1034 | if (utime(fileName, &tval) != 0) { | |
| 1035 | Tcl_AppendStringsToObj(resultPtr, | |
| 1036 | "could not set modification time for file \"", | |
| 1037 | fileName, "\": ", | |
| 1038 | Tcl_PosixError(interp), (char *) NULL); | |
| 1039 | return TCL_ERROR; | |
| 1040 | } | |
| 1041 | /* | |
| 1042 | * Do another stat to ensure that the we return the | |
| 1043 | * new recognized atime - hopefully the same as the | |
| 1044 | * one we sent in. However, fs's like FAT don't | |
| 1045 | * even know what atime is. | |
| 1046 | */ | |
| 1047 | if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { | |
| 1048 | return TCL_ERROR; | |
| 1049 | } | |
| 1050 | } | |
| 1051 | Tcl_SetLongObj(resultPtr, (long) buf.st_mtime); | |
| 1052 | return TCL_OK; | |
| 1053 | } | |
| 1054 | case FILE_MKDIR: { | |
| 1055 | char **argv; | |
| 1056 | int result; | |
| 1057 | ||
| 1058 | if (objc < 3) { | |
| 1059 | Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); | |
| 1060 | return TCL_ERROR; | |
| 1061 | } | |
| 1062 | argv = StringifyObjects(objc, objv); | |
| 1063 | result = TclFileMakeDirsCmd(interp, objc, argv); | |
| 1064 | ckfree((char *) argv); | |
| 1065 | return result; | |
| 1066 | } | |
| 1067 | case FILE_NATIVENAME: { | |
| 1068 | char *fileName; | |
| 1069 | Tcl_DString ds; | |
| 1070 | ||
| 1071 | if (objc != 3) { | |
| 1072 | goto only3Args; | |
| 1073 | } | |
| 1074 | fileName = Tcl_GetString(objv[2]); | |
| 1075 | fileName = Tcl_TranslateFileName(interp, fileName, &ds); | |
| 1076 | if (fileName == NULL) { | |
| 1077 | return TCL_ERROR; | |
| 1078 | } | |
| 1079 | Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds)); | |
| 1080 | Tcl_DStringFree(&ds); | |
| 1081 | return TCL_OK; | |
| 1082 | } | |
| 1083 | case FILE_OWNED: { | |
| 1084 | int value; | |
| 1085 | struct stat buf; | |
| 1086 | ||
| 1087 | if (objc != 3) { | |
| 1088 | goto only3Args; | |
| 1089 | } | |
| 1090 | value = 0; | |
| 1091 | if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { | |
| 1092 | /* | |
| 1093 | * For Windows and Macintosh, there are no user ids | |
| 1094 | * associated with a file, so we always return 1. | |
| 1095 | */ | |
| 1096 | ||
| 1097 | #if (defined(__WIN32__) || defined(MAC_TCL)) | |
| 1098 | value = 1; | |
| 1099 | #else | |
| 1100 | value = (geteuid() == buf.st_uid); | |
| 1101 | #endif | |
| 1102 | } | |
| 1103 | Tcl_SetBooleanObj(resultPtr, value); | |
| 1104 | return TCL_OK; | |
| 1105 | } | |
| 1106 | case FILE_PATHTYPE: { | |
| 1107 | char *fileName; | |
| 1108 | ||
| 1109 | if (objc != 3) { | |
| 1110 | goto only3Args; | |
| 1111 | } | |
| 1112 | fileName = Tcl_GetString(objv[2]); | |
| 1113 | switch (Tcl_GetPathType(fileName)) { | |
| 1114 | case TCL_PATH_ABSOLUTE: | |
| 1115 | Tcl_SetStringObj(resultPtr, "absolute", -1); | |
| 1116 | break; | |
| 1117 | case TCL_PATH_RELATIVE: | |
| 1118 | Tcl_SetStringObj(resultPtr, "relative", -1); | |
| 1119 | break; | |
| 1120 | case TCL_PATH_VOLUME_RELATIVE: | |
| 1121 | Tcl_SetStringObj(resultPtr, "volumerelative", -1); | |
| 1122 | break; | |
| 1123 | } | |
| 1124 | return TCL_OK; | |
| 1125 | } | |
| 1126 | case FILE_READABLE: { | |
| 1127 | if (objc != 3) { | |
| 1128 | goto only3Args; | |
| 1129 | } | |
| 1130 | return CheckAccess(interp, objv[2], R_OK); | |
| 1131 | } | |
| 1132 | case FILE_READLINK: { | |
| 1133 | char *fileName, *contents; | |
| 1134 | Tcl_DString name, link; | |
| 1135 | ||
| 1136 | if (objc != 3) { | |
| 1137 | goto only3Args; | |
| 1138 | } | |
| 1139 | ||
| 1140 | fileName = Tcl_GetString(objv[2]); | |
| 1141 | fileName = Tcl_TranslateFileName(interp, fileName, &name); | |
| 1142 | if (fileName == NULL) { | |
| 1143 | return TCL_ERROR; | |
| 1144 | } | |
| 1145 | ||
| 1146 | /* | |
| 1147 | * If S_IFLNK isn't defined it means that the machine doesn't | |
| 1148 | * support symbolic links, so the file can't possibly be a | |
| 1149 | * symbolic link. Generate an EINVAL error, which is what | |
| 1150 | * happens on machines that do support symbolic links when | |
| 1151 | * you invoke readlink on a file that isn't a symbolic link. | |
| 1152 | */ | |
| 1153 | ||
| 1154 | #ifndef S_IFLNK | |
| 1155 | contents = NULL; | |
| 1156 | errno = EINVAL; | |
| 1157 | #else | |
| 1158 | contents = TclpReadlink(fileName, &link); | |
| 1159 | #endif /* S_IFLNK */ | |
| 1160 | ||
| 1161 | Tcl_DStringFree(&name); | |
| 1162 | if (contents == NULL) { | |
| 1163 | Tcl_AppendResult(interp, "could not readlink \"", | |
| 1164 | Tcl_GetString(objv[2]), "\": ", | |
| 1165 | Tcl_PosixError(interp), (char *) NULL); | |
| 1166 | return TCL_ERROR; | |
| 1167 | } | |
| 1168 | Tcl_DStringResult(interp, &link); | |
| 1169 | return TCL_OK; | |
| 1170 | } | |
| 1171 | case FILE_RENAME: { | |
| 1172 | int result; | |
| 1173 | char **argv; | |
| 1174 | ||
| 1175 | argv = StringifyObjects(objc, objv); | |
| 1176 | result = TclFileRenameCmd(interp, objc, argv); | |
| 1177 | ckfree((char *) argv); | |
| 1178 | return result; | |
| 1179 | } | |
| 1180 | case FILE_ROOTNAME: { | |
| 1181 | int length; | |
| 1182 | char *fileName, *extension; | |
| 1183 | ||
| 1184 | if (objc != 3) { | |
| 1185 | goto only3Args; | |
| 1186 | } | |
| 1187 | fileName = Tcl_GetStringFromObj(objv[2], &length); | |
| 1188 | extension = TclGetExtension(fileName); | |
| 1189 | if (extension == NULL) { | |
| 1190 | Tcl_SetObjResult(interp, objv[2]); | |
| 1191 | } else { | |
| 1192 | Tcl_SetStringObj(resultPtr, fileName, | |
| 1193 | (int) (length - strlen(extension))); | |
| 1194 | } | |
| 1195 | return TCL_OK; | |
| 1196 | } | |
| 1197 | case FILE_SIZE: { | |
| 1198 | struct stat buf; | |
| 1199 | ||
| 1200 | if (objc != 3) { | |
| 1201 | goto only3Args; | |
| 1202 | } | |
| 1203 | if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { | |
| 1204 | return TCL_ERROR; | |
| 1205 | } | |
| 1206 | Tcl_SetLongObj(resultPtr, (long) buf.st_size); | |
| 1207 | return TCL_OK; | |
| 1208 | } | |
| 1209 | case FILE_SPLIT: { | |
| 1210 | int i, argc; | |
| 1211 | char **argv; | |
| 1212 | char *fileName; | |
| 1213 | Tcl_Obj *objPtr; | |
| 1214 | ||
| 1215 | if (objc != 3) { | |
| 1216 | goto only3Args; | |
| 1217 | } | |
| 1218 | fileName = Tcl_GetString(objv[2]); | |
| 1219 | Tcl_SplitPath(fileName, &argc, &argv); | |
| 1220 | for (i = 0; i < argc; i++) { | |
| 1221 | objPtr = Tcl_NewStringObj(argv[i], -1); | |
| 1222 | Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); | |
| 1223 | } | |
| 1224 | ckfree((char *) argv); | |
| 1225 | return TCL_OK; | |
| 1226 | } | |
| 1227 | case FILE_STAT: { | |
| 1228 | char *varName; | |
| 1229 | struct stat buf; | |
| 1230 | ||
| 1231 | if (objc != 4) { | |
| 1232 | Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); | |
| 1233 | return TCL_ERROR; | |
| 1234 | } | |
| 1235 | if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { | |
| 1236 | return TCL_ERROR; | |
| 1237 | } | |
| 1238 | varName = Tcl_GetString(objv[3]); | |
| 1239 | return StoreStatData(interp, varName, &buf); | |
| 1240 | } | |
| 1241 | case FILE_TAIL: { | |
| 1242 | int argc; | |
| 1243 | char **argv; | |
| 1244 | ||
| 1245 | if (objc != 3) { | |
| 1246 | goto only3Args; | |
| 1247 | } | |
| 1248 | if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { | |
| 1249 | return TCL_ERROR; | |
| 1250 | } | |
| 1251 | ||
| 1252 | /* | |
| 1253 | * Return the last component, unless it is the only component, | |
| 1254 | * and it is the root of an absolute path. | |
| 1255 | */ | |
| 1256 | ||
| 1257 | if (argc > 0) { | |
| 1258 | if ((argc > 1) | |
| 1259 | || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { | |
| 1260 | Tcl_SetStringObj(resultPtr, argv[argc - 1], -1); | |
| 1261 | } | |
| 1262 | } | |
| 1263 | ckfree((char *) argv); | |
| 1264 | return TCL_OK; | |
| 1265 | } | |
| 1266 | case FILE_TYPE: { | |
| 1267 | struct stat buf; | |
| 1268 | ||
| 1269 | if (objc != 3) { | |
| 1270 | goto only3Args; | |
| 1271 | } | |
| 1272 | if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { | |
| 1273 | return TCL_ERROR; | |
| 1274 | } | |
| 1275 | Tcl_SetStringObj(resultPtr, | |
| 1276 | GetTypeFromMode((unsigned short) buf.st_mode), -1); | |
| 1277 | return TCL_OK; | |
| 1278 | } | |
| 1279 | case FILE_VOLUMES: { | |
| 1280 | if (objc != 2) { | |
| 1281 | Tcl_WrongNumArgs(interp, 2, objv, NULL); | |
| 1282 | return TCL_ERROR; | |
| 1283 | } | |
| 1284 | return TclpListVolumes(interp); | |
| 1285 | } | |
| 1286 | case FILE_WRITABLE: { | |
| 1287 | if (objc != 3) { | |
| 1288 | goto only3Args; | |
| 1289 | } | |
| 1290 | return CheckAccess(interp, objv[2], W_OK); | |
| 1291 | } | |
| 1292 | } | |
| 1293 | ||
| 1294 | only3Args: | |
| 1295 | Tcl_WrongNumArgs(interp, 2, objv, "name"); | |
| 1296 | return TCL_ERROR; | |
| 1297 | } | |
| 1298 | ||
| 1299 | /* | |
| 1300 | *--------------------------------------------------------------------------- | |
| 1301 | * | |
| 1302 | * SplitPath -- | |
| 1303 | * | |
| 1304 | * Utility procedure used by Tcl_FileObjCmd() to split a path. | |
| 1305 | * Differs from standard Tcl_SplitPath in its handling of home | |
| 1306 | * directories; Tcl_SplitPath preserves the "~" while this | |
| 1307 | * procedure computes the actual full path name. | |
| 1308 | * | |
| 1309 | * Results: | |
| 1310 | * The return value is TCL_OK if the path could be split, TCL_ERROR | |
| 1311 | * otherwise. If TCL_ERROR was returned, an error message is left | |
| 1312 | * in interp. If TCL_OK was returned, *argvPtr is set to a newly | |
| 1313 | * allocated array of strings that represent the individual | |
| 1314 | * directories in the specified path, and *argcPtr is filled with | |
| 1315 | * the length of that array. | |
| 1316 | * | |
| 1317 | * Side effects: | |
| 1318 | * Memory allocated. The caller must eventually free this memory | |
| 1319 | * by calling ckfree() on *argvPtr. | |
| 1320 | * | |
| 1321 | *--------------------------------------------------------------------------- | |
| 1322 | */ | |
| 1323 | ||
| 1324 | static int | |
| 1325 | SplitPath(interp, objPtr, argcPtr, argvPtr) | |
| 1326 | Tcl_Interp *interp; /* Interp for error return. May be NULL. */ | |
| 1327 | Tcl_Obj *objPtr; /* Path to be split. */ | |
| 1328 | int *argcPtr; /* Filled with length of following array. */ | |
| 1329 | char ***argvPtr; /* Filled with array of strings representing | |
| 1330 | * the elements of the specified path. */ | |
| 1331 | { | |
| 1332 | char *fileName; | |
| 1333 | ||
| 1334 | fileName = Tcl_GetString(objPtr); | |
| 1335 | ||
| 1336 | /* | |
| 1337 | * If there is only one element, and it starts with a tilde, | |
| 1338 | * perform tilde substitution and resplit the path. | |
| 1339 | */ | |
| 1340 | ||
| 1341 | Tcl_SplitPath(fileName, argcPtr, argvPtr); | |
| 1342 | if ((*argcPtr == 1) && (fileName[0] == '~')) { | |
| 1343 | Tcl_DString ds; | |
| 1344 | ||
| 1345 | ckfree((char *) *argvPtr); | |
| 1346 | fileName = Tcl_TranslateFileName(interp, fileName, &ds); | |
| 1347 | if (fileName == NULL) { | |
| 1348 | return TCL_ERROR; | |
| 1349 | } | |
| 1350 | Tcl_SplitPath(fileName, argcPtr, argvPtr); | |
| 1351 | Tcl_DStringFree(&ds); | |
| 1352 | } | |
| 1353 | return TCL_OK; | |
| 1354 | } | |
| 1355 | ||
| 1356 | /* | |
| 1357 | *--------------------------------------------------------------------------- | |
| 1358 | * | |
| 1359 | * CheckAccess -- | |
| 1360 | * | |
| 1361 | * Utility procedure used by Tcl_FileObjCmd() to query file | |
| 1362 | * attributes available through the access() system call. | |
| 1363 | * | |
| 1364 | * Results: | |
| 1365 | * Always returns TCL_OK. Sets interp's result to boolean true or | |
| 1366 | * false depending on whether the file has the specified attribute. | |
| 1367 | * | |
| 1368 | * Side effects: | |
| 1369 | * None. | |
| 1370 | * | |
| 1371 | *--------------------------------------------------------------------------- | |
| 1372 | */ | |
| 1373 | ||
| 1374 | static int | |
| 1375 | CheckAccess(interp, objPtr, mode) | |
| 1376 | Tcl_Interp *interp; /* Interp for status return. Must not be | |
| 1377 | * NULL. */ | |
| 1378 | Tcl_Obj *objPtr; /* Name of file to check. */ | |
| 1379 | int mode; /* Attribute to check; passed as argument to | |
| 1380 | * access(). */ | |
| 1381 | { | |
| 1382 | int value; | |
| 1383 | char *fileName; | |
| 1384 | Tcl_DString ds; | |
| 1385 | ||
| 1386 | fileName = Tcl_GetString(objPtr); | |
| 1387 | fileName = Tcl_TranslateFileName(interp, fileName, &ds); | |
| 1388 | if (fileName == NULL) { | |
| 1389 | value = 0; | |
| 1390 | } else { | |
| 1391 | value = (TclAccess(fileName, mode) == 0); | |
| 1392 | Tcl_DStringFree(&ds); | |
| 1393 | } | |
| 1394 | Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); | |
| 1395 | ||
| 1396 | return TCL_OK; | |
| 1397 | } | |
| 1398 | ||
| 1399 | /* | |
| 1400 | *--------------------------------------------------------------------------- | |
| 1401 | * | |
| 1402 | * GetStatBuf -- | |
| 1403 | * | |
| 1404 | * Utility procedure used by Tcl_FileObjCmd() to query file | |
| 1405 | * attributes available through the stat() or lstat() system call. | |
| 1406 | * | |
| 1407 | * Results: | |
| 1408 | * The return value is TCL_OK if the specified file exists and can | |
| 1409 | * be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an | |
| 1410 | * error message is left in interp's result. If TCL_OK is returned, | |
| 1411 | * *statPtr is filled with information about the specified file. | |
| 1412 | * | |
| 1413 | * Side effects: | |
| 1414 | * None. | |
| 1415 | * | |
| 1416 | *--------------------------------------------------------------------------- | |
| 1417 | */ | |
| 1418 | ||
| 1419 | static int | |
| 1420 | GetStatBuf(interp, objPtr, statProc, statPtr) | |
| 1421 | Tcl_Interp *interp; /* Interp for error return. May be NULL. */ | |
| 1422 | Tcl_Obj *objPtr; /* Path name to examine. */ | |
| 1423 | StatProc *statProc; /* Either stat() or lstat() depending on | |
| 1424 | * desired behavior. */ | |
| 1425 | struct stat *statPtr; /* Filled with info about file obtained by | |
| 1426 | * calling (*statProc)(). */ | |
| 1427 | { | |
| 1428 | char *fileName; | |
| 1429 | Tcl_DString ds; | |
| 1430 | int status; | |
| 1431 | ||
| 1432 | fileName = Tcl_GetString(objPtr); | |
| 1433 | fileName = Tcl_TranslateFileName(interp, fileName, &ds); | |
| 1434 | if (fileName == NULL) { | |
| 1435 | return TCL_ERROR; | |
| 1436 | } | |
| 1437 | ||
| 1438 | status = (*statProc)(Tcl_DStringValue(&ds), statPtr); | |
| 1439 | Tcl_DStringFree(&ds); | |
| 1440 | ||
| 1441 | if (status < 0) { | |
| 1442 | if (interp != NULL) { | |
| 1443 | Tcl_AppendResult(interp, "could not read \"", | |
| 1444 | Tcl_GetString(objPtr), "\": ", | |
| 1445 | Tcl_PosixError(interp), (char *) NULL); | |
| 1446 | } | |
| 1447 | return TCL_ERROR; | |
| 1448 | } | |
| 1449 | return TCL_OK; | |
| 1450 | } | |
| 1451 | ||
| 1452 | /* | |
| 1453 | *---------------------------------------------------------------------- | |
| 1454 | * | |
| 1455 | * StoreStatData -- | |
| 1456 | * | |
| 1457 | * This is a utility procedure that breaks out the fields of a | |
| 1458 | * "stat" structure and stores them in textual form into the | |
| 1459 | * elements of an associative array. | |
| 1460 | * | |
| 1461 | * Results: | |
| 1462 | * Returns a standard Tcl return value. If an error occurs then | |
| 1463 | * a message is left in interp's result. | |
| 1464 | * | |
| 1465 | * Side effects: | |
| 1466 | * Elements of the associative array given by "varName" are modified. | |
| 1467 | * | |
| 1468 | *---------------------------------------------------------------------- | |
| 1469 | */ | |
| 1470 | ||
| 1471 | static int | |
| 1472 | StoreStatData(interp, varName, statPtr) | |
| 1473 | Tcl_Interp *interp; /* Interpreter for error reports. */ | |
| 1474 | char *varName; /* Name of associative array variable | |
| 1475 | * in which to store stat results. */ | |
| 1476 | struct stat *statPtr; /* Pointer to buffer containing | |
| 1477 | * stat data to store in varName. */ | |
| 1478 | { | |
| 1479 | char string[TCL_INTEGER_SPACE]; | |
| 1480 | ||
| 1481 | TclFormatInt(string, (long) statPtr->st_dev); | |
| 1482 | if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) | |
| 1483 | == NULL) { | |
| 1484 | return TCL_ERROR; | |
| 1485 | } | |
| 1486 | TclFormatInt(string, (long) statPtr->st_ino); | |
| 1487 | if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) | |
| 1488 | == NULL) { | |
| 1489 | return TCL_ERROR; | |
| 1490 | } | |
| 1491 | TclFormatInt(string, (unsigned short) statPtr->st_mode); | |
| 1492 | if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) | |
| 1493 | == NULL) { | |
| 1494 | return TCL_ERROR; | |
| 1495 | } | |
| 1496 | TclFormatInt(string, (long) statPtr->st_nlink); | |
| 1497 | if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) | |
| 1498 | == NULL) { | |
| 1499 | return TCL_ERROR; | |
| 1500 | } | |
| 1501 | TclFormatInt(string, (long) statPtr->st_uid); | |
| 1502 | if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) | |
| 1503 | == NULL) { | |
| 1504 | return TCL_ERROR; | |
| 1505 | } | |
| 1506 | TclFormatInt(string, (long) statPtr->st_gid); | |
| 1507 | if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) | |
| 1508 | == NULL) { | |
| 1509 | return TCL_ERROR; | |
| 1510 | } | |
| 1511 | sprintf(string, "%lu", (unsigned long) statPtr->st_size); | |
| 1512 | if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) | |
| 1513 | == NULL) { | |
| 1514 | return TCL_ERROR; | |
| 1515 | } | |
| 1516 | TclFormatInt(string, (long) statPtr->st_atime); | |
| 1517 | if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) | |
| 1518 | == NULL) { | |
| 1519 | return TCL_ERROR; | |
| 1520 | } | |
| 1521 | TclFormatInt(string, (long) statPtr->st_mtime); | |
| 1522 | if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) | |
| 1523 | == NULL) { | |
| 1524 | return TCL_ERROR; | |
| 1525 | } | |
| 1526 | TclFormatInt(string, (long) statPtr->st_ctime); | |
| 1527 | if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) | |
| 1528 | == NULL) { | |
| 1529 | return TCL_ERROR; | |
| 1530 | } | |
| 1531 | if (Tcl_SetVar2(interp, varName, "type", | |
| 1532 | GetTypeFromMode((unsigned short) statPtr->st_mode), | |
| 1533 | TCL_LEAVE_ERR_MSG) == NULL) { | |
| 1534 | return TCL_ERROR; | |
| 1535 | } | |
| 1536 | return TCL_OK; | |
| 1537 | } | |
| 1538 | ||
| 1539 | /* | |
| 1540 | *---------------------------------------------------------------------- | |
| 1541 | * | |
| 1542 | * GetTypeFromMode -- | |
| 1543 | * | |
| 1544 | * Given a mode word, returns a string identifying the type of a | |
| 1545 | * file. | |
| 1546 | * | |
| 1547 | * Results: | |
| 1548 | * A static text string giving the file type from mode. | |
| 1549 | * | |
| 1550 | * Side effects: | |
| 1551 | * None. | |
| 1552 | * | |
| 1553 | *---------------------------------------------------------------------- | |
| 1554 | */ | |
| 1555 | ||
| 1556 | static char * | |
| 1557 | GetTypeFromMode(mode) | |
| 1558 | int mode; | |
| 1559 | { | |
| 1560 | if (S_ISREG(mode)) { | |
| 1561 | return "file"; | |
| 1562 | } else if (S_ISDIR(mode)) { | |
| 1563 | return "directory"; | |
| 1564 | } else if (S_ISCHR(mode)) { | |
| 1565 | return "characterSpecial"; | |
| 1566 | } else if (S_ISBLK(mode)) { | |
| 1567 | return "blockSpecial"; | |
| 1568 | } else if (S_ISFIFO(mode)) { | |
| 1569 | return "fifo"; | |
| 1570 | #ifdef S_ISLNK | |
| 1571 | } else if (S_ISLNK(mode)) { | |
| 1572 | return "link"; | |
| 1573 | #endif | |
| 1574 | #ifdef S_ISSOCK | |
| 1575 | } else if (S_ISSOCK(mode)) { | |
| 1576 | return "socket"; | |
| 1577 | #endif | |
| 1578 | } | |
| 1579 | return "unknown"; | |
| 1580 | } | |
| 1581 | ||
| 1582 | /* | |
| 1583 | *---------------------------------------------------------------------- | |
| 1584 | * | |
| 1585 | * Tcl_ForObjCmd -- | |
| 1586 | * | |
| 1587 | * This procedure is invoked to process the "for" Tcl command. | |
| 1588 | * See the user documentation for details on what it does. | |
| 1589 | * | |
| 1590 | * With the bytecode compiler, this procedure is only called when | |
| 1591 | * a command name is computed at runtime, and is "for" or the name | |
| 1592 | * to which "for" was renamed: e.g., | |
| 1593 | * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}" | |
| 1594 | * | |
| 1595 | * Results: | |
| 1596 | * A standard Tcl result. | |
| 1597 | * | |
| 1598 | * Side effects: | |
| 1599 | * See the user documentation. | |
| 1600 | * | |
| 1601 | *---------------------------------------------------------------------- | |
| 1602 | */ | |
| 1603 | ||
| 1604 | /* ARGSUSED */ | |
| 1605 | int | |
| 1606 | Tcl_ForObjCmd(dummy, interp, objc, objv) | |
| 1607 | ClientData dummy; /* Not used. */ | |
| 1608 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 1609 | int objc; /* Number of arguments. */ | |
| 1610 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 1611 | { | |
| 1612 | int result, value; | |
| 1613 | ||
| 1614 | if (objc != 5) { | |
| 1615 | Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); | |
| 1616 | return TCL_ERROR; | |
| 1617 | } | |
| 1618 | ||
| 1619 | result = Tcl_EvalObjEx(interp, objv[1], 0); | |
| 1620 | if (result != TCL_OK) { | |
| 1621 | if (result == TCL_ERROR) { | |
| 1622 | Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); | |
| 1623 | } | |
| 1624 | return result; | |
| 1625 | } | |
| 1626 | while (1) { | |
| 1627 | /* | |
| 1628 | * We need to reset the result before passing it off to | |
| 1629 | * Tcl_ExprBooleanObj. Otherwise, any error message will be appended | |
| 1630 | * to the result of the last evaluation. | |
| 1631 | */ | |
| 1632 | ||
| 1633 | Tcl_ResetResult(interp); | |
| 1634 | result = Tcl_ExprBooleanObj(interp, objv[2], &value); | |
| 1635 | if (result != TCL_OK) { | |
| 1636 | return result; | |
| 1637 | } | |
| 1638 | if (!value) { | |
| 1639 | break; | |
| 1640 | } | |
| 1641 | result = Tcl_EvalObjEx(interp, objv[4], 0); | |
| 1642 | if ((result != TCL_OK) && (result != TCL_CONTINUE)) { | |
| 1643 | if (result == TCL_ERROR) { | |
| 1644 | char msg[32 + TCL_INTEGER_SPACE]; | |
| 1645 | ||
| 1646 | sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); | |
| 1647 | Tcl_AddErrorInfo(interp, msg); | |
| 1648 | } | |
| 1649 | break; | |
| 1650 | } | |
| 1651 | result = Tcl_EvalObjEx(interp, objv[3], 0); | |
| 1652 | if (result == TCL_BREAK) { | |
| 1653 | break; | |
| 1654 | } else if (result != TCL_OK) { | |
| 1655 | if (result == TCL_ERROR) { | |
| 1656 | Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); | |
| 1657 | } | |
| 1658 | return result; | |
| 1659 | } | |
| 1660 | } | |
| 1661 | if (result == TCL_BREAK) { | |
| 1662 | result = TCL_OK; | |
| 1663 | } | |
| 1664 | if (result == TCL_OK) { | |
| 1665 | Tcl_ResetResult(interp); | |
| 1666 | } | |
| 1667 | return result; | |
| 1668 | } | |
| 1669 | ||
| 1670 | /* | |
| 1671 | *---------------------------------------------------------------------- | |
| 1672 | * | |
| 1673 | * Tcl_ForeachObjCmd -- | |
| 1674 | * | |
| 1675 | * This object-based procedure is invoked to process the "foreach" Tcl | |
| 1676 | * command. See the user documentation for details on what it does. | |
| 1677 | * | |
| 1678 | * Results: | |
| 1679 | * A standard Tcl object result. | |
| 1680 | * | |
| 1681 | * Side effects: | |
| 1682 | * See the user documentation. | |
| 1683 | * | |
| 1684 | *---------------------------------------------------------------------- | |
| 1685 | */ | |
| 1686 | ||
| 1687 | /* ARGSUSED */ | |
| 1688 | int | |
| 1689 | Tcl_ForeachObjCmd(dummy, interp, objc, objv) | |
| 1690 | ClientData dummy; /* Not used. */ | |
| 1691 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 1692 | int objc; /* Number of arguments. */ | |
| 1693 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 1694 | { | |
| 1695 | int result = TCL_OK; | |
| 1696 | int i; /* i selects a value list */ | |
| 1697 | int j, maxj; /* Number of loop iterations */ | |
| 1698 | int v; /* v selects a loop variable */ | |
| 1699 | int numLists; /* Count of value lists */ | |
| 1700 | Tcl_Obj *bodyPtr; | |
| 1701 | ||
| 1702 | /* | |
| 1703 | * We copy the argument object pointers into a local array to avoid | |
| 1704 | * the problem that "objv" might become invalid. It is a pointer into | |
| 1705 | * the evaluation stack and that stack might be grown and reallocated | |
| 1706 | * if the loop body requires a large amount of stack space. | |
| 1707 | */ | |
| 1708 | ||
| 1709 | #define NUM_ARGS 9 | |
| 1710 | Tcl_Obj *(argObjStorage[NUM_ARGS]); | |
| 1711 | Tcl_Obj **argObjv = argObjStorage; | |
| 1712 | ||
| 1713 | #define STATIC_LIST_SIZE 4 | |
| 1714 | int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */ | |
| 1715 | int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */ | |
| 1716 | Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */ | |
| 1717 | int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */ | |
| 1718 | Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */ | |
| 1719 | ||
| 1720 | int *index = indexArray; | |
| 1721 | int *varcList = varcListArray; | |
| 1722 | Tcl_Obj ***varvList = varvListArray; | |
| 1723 | int *argcList = argcListArray; | |
| 1724 | Tcl_Obj ***argvList = argvListArray; | |
| 1725 | ||
| 1726 | if (objc < 4 || (objc%2 != 0)) { | |
| 1727 | Tcl_WrongNumArgs(interp, 1, objv, | |
| 1728 | "varList list ?varList list ...? command"); | |
| 1729 | return TCL_ERROR; | |
| 1730 | } | |
| 1731 | ||
| 1732 | /* | |
| 1733 | * Create the object argument array "argObjv". Make sure argObjv is | |
| 1734 | * large enough to hold the objc arguments. | |
| 1735 | */ | |
| 1736 | ||
| 1737 | if (objc > NUM_ARGS) { | |
| 1738 | argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *)); | |
| 1739 | } | |
| 1740 | for (i = 0; i < objc; i++) { | |
| 1741 | argObjv[i] = objv[i]; | |
| 1742 | } | |
| 1743 | ||
| 1744 | /* | |
| 1745 | * Manage numList parallel value lists. | |
| 1746 | * argvList[i] is a value list counted by argcList[i] | |
| 1747 | * varvList[i] is the list of variables associated with the value list | |
| 1748 | * varcList[i] is the number of variables associated with the value list | |
| 1749 | * index[i] is the current pointer into the value list argvList[i] | |
| 1750 | */ | |
| 1751 | ||
| 1752 | numLists = (objc-2)/2; | |
| 1753 | if (numLists > STATIC_LIST_SIZE) { | |
| 1754 | index = (int *) ckalloc(numLists * sizeof(int)); | |
| 1755 | varcList = (int *) ckalloc(numLists * sizeof(int)); | |
| 1756 | varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); | |
| 1757 | argcList = (int *) ckalloc(numLists * sizeof(int)); | |
| 1758 | argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); | |
| 1759 | } | |
| 1760 | for (i = 0; i < numLists; i++) { | |
| 1761 | index[i] = 0; | |
| 1762 | varcList[i] = 0; | |
| 1763 | varvList[i] = (Tcl_Obj **) NULL; | |
| 1764 | argcList[i] = 0; | |
| 1765 | argvList[i] = (Tcl_Obj **) NULL; | |
| 1766 | } | |
| 1767 | ||
| 1768 | /* | |
| 1769 | * Break up the value lists and variable lists into elements | |
| 1770 | */ | |
| 1771 | ||
| 1772 | maxj = 0; | |
| 1773 | for (i = 0; i < numLists; i++) { | |
| 1774 | result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], | |
| 1775 | &varcList[i], &varvList[i]); | |
| 1776 | if (result != TCL_OK) { | |
| 1777 | goto done; | |
| 1778 | } | |
| 1779 | if (varcList[i] < 1) { | |
| 1780 | Tcl_AppendToObj(Tcl_GetObjResult(interp), | |
| 1781 | "foreach varlist is empty", -1); | |
| 1782 | result = TCL_ERROR; | |
| 1783 | goto done; | |
| 1784 | } | |
| 1785 | ||
| 1786 | result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], | |
| 1787 | &argcList[i], &argvList[i]); | |
| 1788 | if (result != TCL_OK) { | |
| 1789 | goto done; | |
| 1790 | } | |
| 1791 | ||
| 1792 | j = argcList[i] / varcList[i]; | |
| 1793 | if ((argcList[i] % varcList[i]) != 0) { | |
| 1794 | j++; | |
| 1795 | } | |
| 1796 | if (j > maxj) { | |
| 1797 | maxj = j; | |
| 1798 | } | |
| 1799 | } | |
| 1800 | ||
| 1801 | /* | |
| 1802 | * Iterate maxj times through the lists in parallel | |
| 1803 | * If some value lists run out of values, set loop vars to "" | |
| 1804 | */ | |
| 1805 | ||
| 1806 | bodyPtr = argObjv[objc-1]; | |
| 1807 | for (j = 0; j < maxj; j++) { | |
| 1808 | for (i = 0; i < numLists; i++) { | |
| 1809 | /* | |
| 1810 | * If a variable or value list object has been converted to | |
| 1811 | * another kind of Tcl object, convert it back to a list object | |
| 1812 | * and refetch the pointer to its element array. | |
| 1813 | */ | |
| 1814 | ||
| 1815 | if (argObjv[1+i*2]->typePtr != &tclListType) { | |
| 1816 | result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], | |
| 1817 | &varcList[i], &varvList[i]); | |
| 1818 | if (result != TCL_OK) { | |
| 1819 | panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i); | |
| 1820 | } | |
| 1821 | } | |
| 1822 | if (argObjv[2+i*2]->typePtr != &tclListType) { | |
| 1823 | result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], | |
| 1824 | &argcList[i], &argvList[i]); | |
| 1825 | if (result != TCL_OK) { | |
| 1826 | panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i); | |
| 1827 | } | |
| 1828 | } | |
| 1829 | ||
| 1830 | for (v = 0; v < varcList[i]; v++) { | |
| 1831 | int k = index[i]++; | |
| 1832 | Tcl_Obj *valuePtr, *varValuePtr; | |
| 1833 | int isEmptyObj = 0; | |
| 1834 | ||
| 1835 | if (k < argcList[i]) { | |
| 1836 | valuePtr = argvList[i][k]; | |
| 1837 | } else { | |
| 1838 | valuePtr = Tcl_NewObj(); /* empty string */ | |
| 1839 | isEmptyObj = 1; | |
| 1840 | } | |
| 1841 | varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], | |
| 1842 | NULL, valuePtr, 0); | |
| 1843 | if (varValuePtr == NULL) { | |
| 1844 | if (isEmptyObj) { | |
| 1845 | Tcl_DecrRefCount(valuePtr); | |
| 1846 | } | |
| 1847 | Tcl_ResetResult(interp); | |
| 1848 | Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | |
| 1849 | "couldn't set loop variable: \"", | |
| 1850 | Tcl_GetString(varvList[i][v]), "\"", (char *) NULL); | |
| 1851 | result = TCL_ERROR; | |
| 1852 | goto done; | |
| 1853 | } | |
| 1854 | ||
| 1855 | } | |
| 1856 | } | |
| 1857 | ||
| 1858 | result = Tcl_EvalObjEx(interp, bodyPtr, 0); | |
| 1859 | if (result != TCL_OK) { | |
| 1860 | if (result == TCL_CONTINUE) { | |
| 1861 | result = TCL_OK; | |
| 1862 | } else if (result == TCL_BREAK) { | |
| 1863 | result = TCL_OK; | |
| 1864 | break; | |
| 1865 | } else if (result == TCL_ERROR) { | |
| 1866 | char msg[32 + TCL_INTEGER_SPACE]; | |
| 1867 | ||
| 1868 | sprintf(msg, "\n (\"foreach\" body line %d)", | |
| 1869 | interp->errorLine); | |
| 1870 | Tcl_AddObjErrorInfo(interp, msg, -1); | |
| 1871 | break; | |
| 1872 | } else { | |
| 1873 | break; | |
| 1874 | } | |
| 1875 | } | |
| 1876 | } | |
| 1877 | if (result == TCL_OK) { | |
| 1878 | Tcl_ResetResult(interp); | |
| 1879 | } | |
| 1880 | ||
| 1881 | done: | |
| 1882 | if (numLists > STATIC_LIST_SIZE) { | |
| 1883 | ckfree((char *) index); | |
| 1884 | ckfree((char *) varcList); | |
| 1885 | ckfree((char *) argcList); | |
| 1886 | ckfree((char *) varvList); | |
| 1887 | ckfree((char *) argvList); | |
| 1888 | } | |
| 1889 | if (argObjv != argObjStorage) { | |
| 1890 | ckfree((char *) argObjv); | |
| 1891 | } | |
| 1892 | return result; | |
| 1893 | #undef STATIC_LIST_SIZE | |
| 1894 | #undef NUM_ARGS | |
| 1895 | } | |
| 1896 | ||
| 1897 | /* | |
| 1898 | *---------------------------------------------------------------------- | |
| 1899 | * | |
| 1900 | * Tcl_FormatObjCmd -- | |
| 1901 | * | |
| 1902 | * This procedure is invoked to process the "format" Tcl command. | |
| 1903 | * See the user documentation for details on what it does. | |
| 1904 | * | |
| 1905 | * Results: | |
| 1906 | * A standard Tcl result. | |
| 1907 | * | |
| 1908 | * Side effects: | |
| 1909 | * See the user documentation. | |
| 1910 | * | |
| 1911 | *---------------------------------------------------------------------- | |
| 1912 | */ | |
| 1913 | ||
| 1914 | /* ARGSUSED */ | |
| 1915 | int | |
| 1916 | Tcl_FormatObjCmd(dummy, interp, objc, objv) | |
| 1917 | ClientData dummy; /* Not used. */ | |
| 1918 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 1919 | int objc; /* Number of arguments. */ | |
| 1920 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 1921 | { | |
| 1922 | char *format; /* Used to read characters from the format | |
| 1923 | * string. */ | |
| 1924 | int formatLen; /* The length of the format string */ | |
| 1925 | char *endPtr; /* Points to the last char in format array */ | |
| 1926 | char newFormat[40]; /* A new format specifier is generated here. */ | |
| 1927 | int width; /* Field width from field specifier, or 0 if | |
| 1928 | * no width given. */ | |
| 1929 | int precision; /* Field precision from field specifier, or 0 | |
| 1930 | * if no precision given. */ | |
| 1931 | int size; /* Number of bytes needed for result of | |
| 1932 | * conversion, based on type of conversion | |
| 1933 | * ("e", "s", etc.), width, and precision. */ | |
| 1934 | int intValue; /* Used to hold value to pass to sprintf, if | |
| 1935 | * it's a one-word integer or char value */ | |
| 1936 | char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if | |
| 1937 | * it's a one-word value. */ | |
| 1938 | double doubleValue; /* Used to hold value to pass to sprintf if | |
| 1939 | * it's a double value. */ | |
| 1940 | int whichValue; /* Indicates which of intValue, ptrValue, | |
| 1941 | * or doubleValue has the value to pass to | |
| 1942 | * sprintf, according to the following | |
| 1943 | * definitions: */ | |
| 1944 | # define INT_VALUE 0 | |
| 1945 | # define CHAR_VALUE 1 | |
| 1946 | # define PTR_VALUE 2 | |
| 1947 | # define DOUBLE_VALUE 3 | |
| 1948 | # define STRING_VALUE 4 | |
| 1949 | # define MAX_FLOAT_SIZE 320 | |
| 1950 | ||
| 1951 | Tcl_Obj *resultPtr; /* Where result is stored finally. */ | |
| 1952 | char staticBuf[MAX_FLOAT_SIZE + 1]; | |
| 1953 | /* A static buffer to copy the format results | |
| 1954 | * into */ | |
| 1955 | char *dst = staticBuf; /* The buffer that sprintf writes into each | |
| 1956 | * time the format processes a specifier */ | |
| 1957 | int dstSize = MAX_FLOAT_SIZE; | |
| 1958 | /* The size of the dst buffer */ | |
| 1959 | int noPercent; /* Special case for speed: indicates there's | |
| 1960 | * no field specifier, just a string to copy.*/ | |
| 1961 | int objIndex; /* Index of argument to substitute next. */ | |
| 1962 |