summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdAH.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdAH.c')
-rw-r--r--generic/tclCmdAH.c1541
1 files changed, 784 insertions, 757 deletions
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index c2fae75..a3a6279 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1,4 +1,4 @@
-/*
+/*
* tclCmdAH.c --
*
* This file contains the top-level command routines for most of
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.63 2005/06/17 23:41:03 dkf Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.64 2005/07/17 21:17:30 dkf Exp $
*/
#include "tclInt.h"
@@ -35,12 +35,12 @@ static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
*
* Tcl_BreakObjCmd --
*
- * This procedure is invoked to process the "break" Tcl command.
- * See the user documentation for details on what it does.
+ * 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"
+ * 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.
@@ -71,8 +71,8 @@ Tcl_BreakObjCmd(dummy, interp, objc, objv)
*
* Tcl_CaseObjCmd --
*
- * This procedure is invoked to process the "case" Tcl command.
- * See the user documentation for details on what it does.
+ * 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.
@@ -116,8 +116,8 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
caseObjv = objv + i;
/*
- * If all of the pattern/command pairs are lumped into a single
- * argument, split them out again.
+ * If all of the pattern/command pairs are lumped into a single argument,
+ * split them out again.
*/
if (caseObjc == 1) {
@@ -140,8 +140,8 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
}
/*
- * Check for special case of single pattern (no list) with
- * no backslash sequences.
+ * Check for special case of single pattern (no list) with no
+ * backslash sequences.
*/
pat = TclGetString(caseObjv[i]);
@@ -162,8 +162,8 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
}
/*
- * Break up pattern lists, then check each of the patterns
- * in the list.
+ * Break up pattern lists, then check each of the patterns in the
+ * list.
*/
result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
@@ -182,7 +182,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
}
}
- match:
+ match:
if (body != -1) {
armPtr = caseObjv[body - 1];
result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
@@ -209,7 +209,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
*
* Tcl_CatchObjCmd --
*
- * This object-based procedure is invoked to process the "catch" Tcl
+ * This object-based procedure is invoked to process the "catch" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
@@ -251,6 +251,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
/*
* We disable catch in interpreters where the limit has been exceeded.
*/
+
if (Tcl_LimitExceeded(interp)) {
char msg[32 + TCL_INTEGER_SPACE];
@@ -263,8 +264,8 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
Tcl_GetObjResult(interp), 0)) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp,
- "couldn't save command result in variable", NULL);
+ Tcl_AppendResult(interp,
+ "couldn't save command result in variable", NULL);
return TCL_ERROR;
}
}
@@ -275,7 +276,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
Tcl_DecrRefCount(options);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
- "couldn't save return options in variable", NULL);
+ "couldn't save return options in variable", NULL);
return TCL_ERROR;
}
}
@@ -290,8 +291,8 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
*
* Tcl_CdObjCmd --
*
- * This procedure is invoked to process the "cd" Tcl command.
- * See the user documentation for details on what it does.
+ * 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.
@@ -376,12 +377,12 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv)
*
* Tcl_ContinueObjCmd --
*
- * This procedure is invoked to process the "continue" Tcl command.
- * See the user documentation for details on what it does.
+ * 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"
+ * 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.
@@ -430,10 +431,7 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int index, length;
- Tcl_Encoding encoding;
- char *stringPtr;
- Tcl_DString ds;
+ int index;
static CONST char *optionStrings[] = {
"convertfrom", "convertto", "names", "system",
@@ -445,7 +443,7 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv)
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
- return TCL_ERROR;
+ return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
@@ -453,76 +451,78 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv)
}
switch ((enum options) index) {
- case ENC_CONVERTTO:
- case ENC_CONVERTFROM: {
- Tcl_Obj *data;
- if (objc == 3) {
- encoding = Tcl_GetEncoding(interp, NULL);
- data = objv[2];
- } else if (objc == 4) {
- if (TclGetEncodingFromObj(interp, objv[2], &encoding)
- != TCL_OK) {
- return TCL_ERROR;
- }
- data = objv[3];
- } else {
- Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
+ case ENC_CONVERTTO:
+ case ENC_CONVERTFROM: {
+ Tcl_Obj *data;
+ Tcl_DString ds;
+ Tcl_Encoding encoding;
+ int length;
+ char *stringPtr;
+
+ if (objc == 3) {
+ encoding = Tcl_GetEncoding(interp, NULL);
+ data = objv[2];
+ } else if (objc == 4) {
+ if (TclGetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) {
return TCL_ERROR;
}
+ data = objv[3];
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
+ return TCL_ERROR;
+ }
- if ((enum options) index == ENC_CONVERTFROM) {
- /*
- * Treat the string as binary data.
- */
+ if ((enum options) index == ENC_CONVERTFROM) {
+ /*
+ * Treat the string as binary data.
+ */
- stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
- Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds);
+ stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
+ Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds);
- /*
- * Note that we cannot use Tcl_DStringResult here because
- * it will truncate the string at the first null byte.
- */
+ /*
+ * Note that we cannot use Tcl_DStringResult here because it will
+ * truncate the string at the first null byte.
+ */
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
- Tcl_DStringFree(&ds);
- } else {
- /*
- * Store the result as binary data.
- */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
+ Tcl_DStringFree(&ds);
+ } else {
+ /*
+ * Store the result as binary data.
+ */
- stringPtr = Tcl_GetStringFromObj(data, &length);
- Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
- Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
- (unsigned char *) Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds)));
- Tcl_DStringFree(&ds);
- }
+ stringPtr = Tcl_GetStringFromObj(data, &length);
+ Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
+ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
+ (unsigned char *) Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds)));
+ Tcl_DStringFree(&ds);
+ }
- Tcl_FreeEncoding(encoding);
- break;
+ Tcl_FreeEncoding(encoding);
+ break;
+ }
+ case ENC_NAMES:
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
}
- case ENC_NAMES: {
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
- Tcl_GetEncodingNames(interp);
- break;
+ Tcl_GetEncodingNames(interp);
+ break;
+ case ENC_SYSTEM:
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
+ return TCL_ERROR;
}
- case ENC_SYSTEM: {
- if (objc > 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
- return TCL_ERROR;
- }
- if (objc == 2) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- Tcl_GetEncodingName(NULL), -1));
- } else {
- return Tcl_SetSystemEncoding(interp, TclGetString(objv[2]));
- }
- break;
+ if (objc == 2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ Tcl_GetEncodingName(NULL), -1));
+ } else {
+ return Tcl_SetSystemEncoding(interp, TclGetString(objv[2]));
}
+ break;
}
return TCL_OK;
}
@@ -572,8 +572,8 @@ TclEncodingDirsObjCmd(dummy, interp, objc, objv)
*
* Tcl_ErrorObjCmd --
*
- * This procedure is invoked to process the "error" Tcl command.
- * See the user documentation for details on what it does.
+ * 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.
@@ -622,7 +622,7 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv)
*
* Tcl_EvalObjCmd --
*
- * This object-based procedure is invoked to process the "eval" Tcl
+ * This object-based procedure is invoked to process the "eval" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
@@ -655,8 +655,8 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv)
} 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.
+ * 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);
@@ -675,8 +675,8 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv)
*
* Tcl_ExitObjCmd --
*
- * This procedure is invoked to process the "exit" Tcl command.
- * See the user documentation for details on what it does.
+ * 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.
@@ -721,8 +721,8 @@ Tcl_ExitObjCmd(dummy, interp, objc, objv)
* 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
+ * 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")
@@ -743,7 +743,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
+{
register Tcl_Obj *objPtr;
Tcl_Obj *resultPtr;
int result;
@@ -771,13 +771,12 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv)
*
* 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.
- * With the object-based Tcl_FS APIs, the above NOTE may no
- * longer be true. In any case this assertion should be tested.
- *
+ * 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. With the
+ * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any
+ * case this assertion should be tested.
+ *
* Results:
* A standard Tcl result.
*
@@ -797,20 +796,20 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
{
int index;
-/*
- * This list of constants should match the fileOption string array below.
- */
+ /*
+ * This list of constants should match the fileOption string array below.
+ */
static CONST char *fileOptions[] = {
"atime", "attributes", "channels", "copy",
"delete",
"dirname", "executable", "exists", "extension",
"isdirectory", "isfile", "join", "link",
- "lstat", "mtime", "mkdir", "nativename",
+ "lstat", "mtime", "mkdir", "nativename",
"normalize", "owned",
"pathtype", "readable", "readlink", "rename",
- "rootname", "separator", "size", "split",
- "stat", "system",
+ "rootname", "separator", "size", "split",
+ "stat", "system",
"tail", "type", "volumes", "writable",
(char *) NULL
};
@@ -818,18 +817,18 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY,
FCMD_DELETE,
FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION,
- FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK,
- FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME,
- FCMD_NORMALIZE, FCMD_OWNED,
+ FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK,
+ FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME,
+ FCMD_NORMALIZE, FCMD_OWNED,
FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME,
- FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT,
- FCMD_STAT, FCMD_SYSTEM,
+ FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT,
+ FCMD_STAT, FCMD_SYSTEM,
FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
- return TCL_ERROR;
+ return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
&index) != TCL_OK) {
@@ -837,565 +836,580 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
}
switch ((enum options) index) {
- case FCMD_ATIME: {
- Tcl_StatBuf buf;
- struct utimbuf tval;
+ case FCMD_ATIME: {
+ Tcl_StatBuf buf;
+ struct utimbuf tval;
- if ((objc < 3) || (objc > 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
+ if ((objc < 3) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 4) {
+ /*
+ * Need separate variable for reading longs from an object on
+ * 64-bit platforms. [Bug #698146]
+ */
+
+ long newTime;
+
+ if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
+
+ tval.actime = newTime;
+ tval.modtime = buf.st_mtime;
+ if (Tcl_FSUtime(objv[2], &tval) != 0) {
+ Tcl_AppendResult(interp,
+ "could not set access time for file \"",
+ TclGetString(objv[2]), "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
return TCL_ERROR;
}
- if (objc == 4) {
- /*
- * Need separate variable for reading longs from an
- * object on 64-bit platforms. [Bug #698146]
- */
- long newTime;
- if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
- 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.
+ */
- tval.actime = newTime;
- tval.modtime = buf.st_mtime;
- if (Tcl_FSUtime(objv[2], &tval) != 0) {
- Tcl_AppendResult(interp,
- "could not set access time for file \"",
- TclGetString(objv[2]), "\": ",
- 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], Tcl_FSStat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime));
+ }
+ Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime));
+ return TCL_OK;
+ }
+ case FCMD_ATTRIBUTES:
+ return TclFileAttrsCmd(interp, objc, objv);
+ case FCMD_CHANNELS:
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
+ return TCL_ERROR;
+ }
+ return Tcl_GetChannelNamesEx(interp,
+ ((objc == 2) ? NULL : TclGetString(objv[2])));
+ case FCMD_COPY:
+ return TclFileCopyCmd(interp, objc, objv);
+ case FCMD_DELETE:
+ return TclFileDeleteCmd(interp, objc, objv);
+ case FCMD_DIRNAME: {
+ Tcl_Obj *dirPtr;
+
+ if (objc != 3) {
+ goto only3Args;
+ }
+ dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME);
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
+ } else {
+ Tcl_SetObjResult(interp, dirPtr);
+ Tcl_DecrRefCount(dirPtr);
return TCL_OK;
}
- case FCMD_ATTRIBUTES:
- return TclFileAttrsCmd(interp, objc, objv);
- case FCMD_CHANNELS:
- if ((objc < 2) || (objc > 3)) {
- Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
- return TCL_ERROR;
- }
- return Tcl_GetChannelNamesEx(interp,
- ((objc == 2) ? NULL : TclGetString(objv[2])));
- case FCMD_COPY:
- return TclFileCopyCmd(interp, objc, objv);
- case FCMD_DELETE:
- return TclFileDeleteCmd(interp, objc, objv);
- case FCMD_DIRNAME: {
- Tcl_Obj *dirPtr;
-
- if (objc != 3) {
- goto only3Args;
- }
- dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME);
- if (dirPtr == NULL) {
- return TCL_ERROR;
- } else {
- Tcl_SetObjResult(interp, dirPtr);
- Tcl_DecrRefCount(dirPtr);
- return TCL_OK;
- }
+ }
+ case FCMD_EXECUTABLE:
+ if (objc != 3) {
+ goto only3Args;
}
- case FCMD_EXECUTABLE:
- if (objc != 3) {
- goto only3Args;
- }
- return CheckAccess(interp, objv[2], X_OK);
- case FCMD_EXISTS:
- if (objc != 3) {
- goto only3Args;
- }
- return CheckAccess(interp, objv[2], F_OK);
- case FCMD_EXTENSION: {
- Tcl_Obj *ext;
-
- if (objc != 3) {
- goto only3Args;
- }
- ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION);
- if (ext != NULL) {
- Tcl_SetObjResult(interp, ext);
- Tcl_DecrRefCount(ext);
- return TCL_OK;
- } else {
- return TCL_ERROR;
- }
+ return CheckAccess(interp, objv[2], X_OK);
+ case FCMD_EXISTS:
+ if (objc != 3) {
+ goto only3Args;
}
- case FCMD_ISDIRECTORY: {
- int value;
- Tcl_StatBuf buf;
+ return CheckAccess(interp, objv[2], F_OK);
+ case FCMD_EXTENSION: {
+ Tcl_Obj *ext;
- if (objc != 3) {
- goto only3Args;
- }
- value = 0;
- if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
- value = S_ISDIR(buf.st_mode);
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
+ if (objc != 3) {
+ goto only3Args;
+ }
+ ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION);
+ if (ext != NULL) {
+ Tcl_SetObjResult(interp, ext);
+ Tcl_DecrRefCount(ext);
return TCL_OK;
+ } else {
+ return TCL_ERROR;
}
- case FCMD_ISFILE: {
- int value;
- Tcl_StatBuf buf;
+ }
+ case FCMD_ISDIRECTORY: {
+ int value;
+ Tcl_StatBuf buf;
- if (objc != 3) {
- goto only3Args;
- }
- value = 0;
- if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
- value = S_ISREG(buf.st_mode);
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
- return TCL_OK;
+ if (objc != 3) {
+ goto only3Args;
}
- case FCMD_JOIN: {
- Tcl_Obj *resObj;
+ value = 0;
+ if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
+ value = S_ISDIR(buf.st_mode);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
+ return TCL_OK;
+ }
+ case FCMD_ISFILE: {
+ int value;
+ Tcl_StatBuf buf;
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
- return TCL_ERROR;
- }
- resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
- Tcl_SetObjResult(interp, resObj);
- return TCL_OK;
+ if (objc != 3) {
+ goto only3Args;
+ }
+ value = 0;
+ if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
+ value = S_ISREG(buf.st_mode);
}
- case FCMD_LINK: {
- Tcl_Obj *contents;
- int index;
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
+ return TCL_OK;
+ }
+ case FCMD_JOIN: {
+ Tcl_Obj *resObj;
- if (objc < 3 || objc > 5) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "?-linktype? linkname ?target?");
- return TCL_ERROR;
- }
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+ resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
+ Tcl_SetObjResult(interp, resObj);
+ return TCL_OK;
+ }
+ case FCMD_LINK: {
+ Tcl_Obj *contents;
+ int index;
+
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?");
+ return TCL_ERROR;
+ }
- /* Index of the 'source' argument */
+ /*
+ * Index of the 'source' argument.
+ */
+
+ if (objc == 5) {
+ index = 3;
+ } else {
+ index = 2;
+ }
+
+ if (objc > 3) {
+ int linkAction;
if (objc == 5) {
- index = 3;
+ /*
+ * We have a '-linktype' argument.
+ */
+
+ static CONST char *linkTypes[] = {
+ "-symbolic", "-hard", NULL
+ };
+ if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch",
+ 0, &linkAction) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (linkAction == 0) {
+ linkAction = TCL_CREATE_SYMBOLIC_LINK;
+ } else {
+ linkAction = TCL_CREATE_HARD_LINK;
+ }
} else {
- index = 2;
+ linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
+ }
+ if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+ return TCL_ERROR;
}
- if (objc > 3) {
- int linkAction;
- if (objc == 5) {
- /* We have a '-linktype' argument */
- static CONST char *linkTypes[] = {
- "-symbolic", "-hard", NULL
- };
- if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes,
- "switch", 0, &linkAction) != TCL_OK) {
+ /*
+ * Create link from source to target.
+ */
+
+ contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
+ if (contents == NULL) {
+ /*
+ * We handle three common error cases specially, and for all
+ * other errors, we use the standard posix error message.
+ */
+
+ if (errno == EEXIST) {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ TclGetString(objv[index]),
+ "\": that path already exists", (char *) NULL);
+ } else if (errno == ENOENT) {
+ /*
+ * There are two cases here: either the target doesn't
+ * exist, or the directory of the src doesn't exist.
+ */
+
+ int access;
+ Tcl_Obj *dirPtr = TclPathPart(interp, objv[index],
+ TCL_PATH_DIRNAME);
+
+ if (dirPtr == NULL) {
return TCL_ERROR;
}
- if (linkAction == 0) {
- linkAction = TCL_CREATE_SYMBOLIC_LINK;
- } else {
- linkAction = TCL_CREATE_HARD_LINK;
- }
- } else {
- linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
- }
- if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
- return TCL_ERROR;
- }
- /* Create link from source to target */
- contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
- if (contents == NULL) {
- /*
- * We handle three common error cases specially, and
- * for all other errors, we use the standard posix
- * error message.
- */
- if (errno == EEXIST) {
+ access = Tcl_FSAccess(dirPtr, F_OK);
+ Tcl_DecrRefCount(dirPtr);
+ if (access != 0) {
Tcl_AppendResult(interp,
- "could not create new link \"",
- TclGetString(objv[index]),
- "\": that path already exists", (char *) NULL);
- } else if (errno == ENOENT) {
- /*
- * There are two cases here: either the target
- * doesn't exist, or the directory of the src
- * doesn't exist.
- */
- int access;
- Tcl_Obj *dirPtr = TclPathPart(interp, objv[index],
- TCL_PATH_DIRNAME);
- if (dirPtr == NULL) {
- return TCL_ERROR;
- }
- access = Tcl_FSAccess(dirPtr, F_OK);
- Tcl_DecrRefCount(dirPtr);
- if (access != 0) {
- Tcl_AppendResult(interp,
- "could not create new link \"",
- TclGetString(objv[index]),
- "\": no such file or directory",
- (char *) NULL);
- } else {
- Tcl_AppendResult(interp,
- "could not create new link \"",
- TclGetString(objv[index]),
- "\": target \"",
- TclGetString(objv[index+1]),
- "\" doesn't exist",
- (char *) NULL);
- }
+ "could not create new link \"",
+ TclGetString(objv[index]),
+ "\": no such file or directory",
+ (char *) NULL);
} else {
Tcl_AppendResult(interp,
"could not create new link \"",
- TclGetString(objv[index]), "\" pointing to \"",
- TclGetString(objv[index+1]), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ TclGetString(objv[index]), "\": target \"",
+ TclGetString(objv[index+1]),
+ "\" doesn't exist", (char *) NULL);
}
- return TCL_ERROR;
- }
- } else {
- if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
- return TCL_ERROR;
- }
- /* Read link */
- contents = Tcl_FSLink(objv[index], NULL, 0);
- if (contents == NULL) {
- Tcl_AppendResult(interp, "could not read link \"",
- TclGetString(objv[index]), "\": ",
+ } else {
+ Tcl_AppendResult(interp,
+ "could not create new link \"",
+ TclGetString(objv[index]), "\" pointing to \"",
+ TclGetString(objv[index+1]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
}
- }
- Tcl_SetObjResult(interp, contents);
- if (objc == 3) {
- /*
- * If we are reading a link, we need to free this
- * result refCount. If we are creating a link, this
- * will just be objv[index+1], and so we don't own it.
- */
- Tcl_DecrRefCount(contents);
- }
- return TCL_OK;
- }
- case FCMD_LSTAT: {
- Tcl_StatBuf buf;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "name varName");
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
+ } else {
+ if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
- return StoreStatData(interp, objv[3], &buf);
- }
- case FCMD_MTIME: {
- Tcl_StatBuf buf;
- struct utimbuf tval;
- if ((objc < 3) || (objc > 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
- return TCL_ERROR;
- }
- if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
+ /*
+ * Read link
+ */
+
+ contents = Tcl_FSLink(objv[index], NULL, 0);
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not read link \"",
+ TclGetString(objv[index]), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
- if (objc == 4) {
- /*
- * Need separate variable for reading longs from an
- * object on 64-bit platforms. [Bug #698146]
- */
- long newTime;
+ }
+ Tcl_SetObjResult(interp, contents);
+ if (objc == 3) {
+ /*
+ * If we are reading a link, we need to free this result refCount.
+ * If we are creating a link, this will just be objv[index+1], and
+ * so we don't own it.
+ */
- if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
- return TCL_ERROR;
- }
+ Tcl_DecrRefCount(contents);
+ }
+ return TCL_OK;
+ }
+ case FCMD_LSTAT: {
+ Tcl_StatBuf buf;
- tval.actime = buf.st_atime;
- tval.modtime = newTime;
- if (Tcl_FSUtime(objv[2], &tval) != 0) {
- Tcl_AppendResult(interp,
- "could not set modification time for file \"",
- TclGetString(objv[2]), "\": ",
- 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], Tcl_FSStat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
- }
- Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime));
- return TCL_OK;
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name varName");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return StoreStatData(interp, objv[3], &buf);
+ }
+ case FCMD_MTIME: {
+ Tcl_StatBuf buf;
+ struct utimbuf tval;
+
+ if ((objc < 3) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
+ return TCL_ERROR;
}
- case FCMD_MKDIR:
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 4) {
+ /*
+ * Need separate variable for reading longs from an object on
+ * 64-bit platforms. [Bug #698146]
+ */
+
+ long newTime;
+
+ if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
return TCL_ERROR;
}
- return TclFileMakeDirsCmd(interp, objc, objv);
- case FCMD_NATIVENAME: {
- CONST char *fileName;
- Tcl_DString ds;
- if (objc != 3) {
- goto only3Args;
- }
- fileName = TclGetString(objv[2]);
- fileName = Tcl_TranslateFileName(interp, fileName, &ds);
- if (fileName == NULL) {
+ tval.actime = buf.st_atime;
+ tval.modtime = newTime;
+ if (Tcl_FSUtime(objv[2], &tval) != 0) {
+ Tcl_AppendResult(interp,
+ "could not set modification time for file \"",
+ TclGetString(objv[2]), "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName,
- Tcl_DStringLength(&ds)));
- Tcl_DStringFree(&ds);
- return TCL_OK;
- }
- case FCMD_NORMALIZE: {
- Tcl_Obj *fileName;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "filename");
+ /*
+ * 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], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
+ }
+ Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime));
+ return TCL_OK;
+ }
+ case FCMD_MKDIR:
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+ return TclFileMakeDirsCmd(interp, objc, objv);
+ case FCMD_NATIVENAME: {
+ CONST char *fileName;
+ Tcl_DString ds;
- fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
- if (fileName == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, fileName);
- return TCL_OK;
+ if (objc != 3) {
+ goto only3Args;
+ }
+ fileName = TclGetString(objv[2]);
+ fileName = Tcl_TranslateFileName(interp, fileName, &ds);
+ if (fileName == NULL) {
+ return TCL_ERROR;
}
- case FCMD_OWNED: {
- int value;
- Tcl_StatBuf buf;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName,
+ Tcl_DStringLength(&ds)));
+ Tcl_DStringFree(&ds);
+ return TCL_OK;
+ }
+ case FCMD_NORMALIZE: {
+ Tcl_Obj *fileName;
- if (objc != 3) {
- goto only3Args;
- }
- value = 0;
- if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
- /*
- * For Windows, there are no user ids
- * associated with a file, so we always return 1.
- */
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "filename");
+ return TCL_ERROR;
+ }
+
+ fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
+ if (fileName == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, fileName);
+ return TCL_OK;
+ }
+ case FCMD_OWNED: {
+ int value;
+ Tcl_StatBuf buf;
+
+ if (objc != 3) {
+ goto only3Args;
+ }
+ value = 0;
+ if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
+ /*
+ * For Windows, there are no user ids associated with a file, so
+ * we always return 1.
+ */
#if defined(__WIN32__)
- value = 1;
+ value = 1;
#else
- value = (geteuid() == buf.st_uid);
+ value = (geteuid() == buf.st_uid);
#endif
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
- return TCL_OK;
}
- case FCMD_PATHTYPE:
- if (objc != 3) {
- goto only3Args;
- }
- switch (Tcl_FSGetPathType(objv[2])) {
- case TCL_PATH_ABSOLUTE:
- Tcl_SetObjResult(interp, Tcl_NewStringObj("absolute", -1));
- break;
- case TCL_PATH_RELATIVE:
- Tcl_SetObjResult(interp, Tcl_NewStringObj("relative", -1));
- break;
- case TCL_PATH_VOLUME_RELATIVE:
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("volumerelative", -1));
- break;
- }
- return TCL_OK;
- case FCMD_READABLE:
- if (objc != 3) {
- goto only3Args;
- }
- return CheckAccess(interp, objv[2], R_OK);
- case FCMD_READLINK: {
- Tcl_Obj *contents;
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
+ return TCL_OK;
+ }
+ case FCMD_PATHTYPE:
+ if (objc != 3) {
+ goto only3Args;
+ }
+ switch (Tcl_FSGetPathType(objv[2])) {
+ case TCL_PATH_ABSOLUTE:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("absolute", -1));
+ break;
+ case TCL_PATH_RELATIVE:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("relative", -1));
+ break;
+ case TCL_PATH_VOLUME_RELATIVE:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("volumerelative", -1));
+ break;
+ }
+ return TCL_OK;
+ case FCMD_READABLE:
+ if (objc != 3) {
+ goto only3Args;
+ }
+ return CheckAccess(interp, objv[2], R_OK);
+ case FCMD_READLINK: {
+ Tcl_Obj *contents;
- if (objc != 3) {
- goto only3Args;
- }
+ if (objc != 3) {
+ goto only3Args;
+ }
- if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
- return TCL_ERROR;
- }
+ if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
+ return TCL_ERROR;
+ }
- contents = Tcl_FSLink(objv[2], NULL, 0);
+ contents = Tcl_FSLink(objv[2], NULL, 0);
- if (contents == NULL) {
- Tcl_AppendResult(interp, "could not readlink \"",
- TclGetString(objv[2]), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, contents);
- Tcl_DecrRefCount(contents);
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not readlink \"",
+ TclGetString(objv[2]), "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, contents);
+ Tcl_DecrRefCount(contents);
+ return TCL_OK;
+ }
+ case FCMD_RENAME:
+ return TclFileRenameCmd(interp, objc, objv);
+ case FCMD_ROOTNAME: {
+ Tcl_Obj *root;
+
+ if (objc != 3) {
+ goto only3Args;
+ }
+ root = TclPathPart(interp, objv[2], TCL_PATH_ROOT);
+ if (root != NULL) {
+ Tcl_SetObjResult(interp, root);
+ Tcl_DecrRefCount(root);
return TCL_OK;
+ } else {
+ return TCL_ERROR;
}
- case FCMD_RENAME:
- return TclFileRenameCmd(interp, objc, objv);
- case FCMD_ROOTNAME: {
- Tcl_Obj *root;
+ }
+ case FCMD_SEPARATOR:
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?name?");
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ char *separator = NULL; /* lint */
- if (objc != 3) {
- goto only3Args;
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ separator = "/";
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ separator = "\\";
+ break;
}
- root = TclPathPart(interp, objv[2], TCL_PATH_ROOT);
- if (root != NULL) {
- Tcl_SetObjResult(interp, root);
- Tcl_DecrRefCount(root);
- return TCL_OK;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
+ } else {
+ Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
+ if (separatorObj != NULL) {
+ Tcl_SetObjResult(interp, separatorObj);
} else {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("Unrecognised path",-1));
return TCL_ERROR;
}
}
- case FCMD_SEPARATOR:
- if ((objc < 2) || (objc > 3)) {
- Tcl_WrongNumArgs(interp, 2, objv, "?name?");
- return TCL_ERROR;
- }
- if (objc == 2) {
- char *separator = NULL; /* lint */
- switch (tclPlatform) {
- case TCL_PLATFORM_UNIX:
- separator = "/";
- break;
- case TCL_PLATFORM_WINDOWS:
- separator = "\\";
- break;
- }
- Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
- } else {
- Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
- if (separatorObj != NULL) {
- Tcl_SetObjResult(interp, separatorObj);
- } else {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("Unrecognised path",-1));
- return TCL_ERROR;
- }
- }
- return TCL_OK;
- case FCMD_SIZE: {
- Tcl_StatBuf buf;
+ return TCL_OK;
+ case FCMD_SIZE: {
+ Tcl_StatBuf buf;
- if (objc != 3) {
- goto only3Args;
- }
- if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp,
- Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size));
- return TCL_OK;
+ if (objc != 3) {
+ goto only3Args;
}
- case FCMD_SPLIT: {
- Tcl_Obj *res;
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp,
+ Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size));
+ return TCL_OK;
+ }
+ case FCMD_SPLIT: {
+ Tcl_Obj *res;
- if (objc != 3) {
- goto only3Args;
- }
- res = Tcl_FSSplitPath(objv[2], NULL);
- if (res == NULL) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
+ if (objc != 3) {
+ goto only3Args;
+ }
+ res = Tcl_FSSplitPath(objv[2], NULL);
+ if (res == NULL) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "could not read \"",
TclGetString(objv[2]),
"\": no such file or directory", (char *) NULL);
- }
- return TCL_ERROR;
- } else {
- Tcl_SetObjResult(interp, res);
- return TCL_OK;
}
+ return TCL_ERROR;
+ } else {
+ Tcl_SetObjResult(interp, res);
+ return TCL_OK;
}
- case FCMD_STAT: {
- Tcl_StatBuf buf;
+ }
+ case FCMD_STAT: {
+ Tcl_StatBuf buf;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
- return TCL_ERROR;
- }
- if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
- return StoreStatData(interp, objv[3], &buf);
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
+ return TCL_ERROR;
}
- case FCMD_SYSTEM: {
- Tcl_Obj* fsInfo;
-
- if (objc != 3) {
- goto only3Args;
- }
- fsInfo = Tcl_FSFileSystemInfo(objv[2]);
- if (fsInfo != NULL) {
- Tcl_SetObjResult(interp, fsInfo);
- return TCL_OK;
- } else {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("Unrecognised path",-1));
- return TCL_ERROR;
- }
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
}
- case FCMD_TAIL: {
- Tcl_Obj *dirPtr;
+ return StoreStatData(interp, objv[3], &buf);
+ }
+ case FCMD_SYSTEM: {
+ Tcl_Obj* fsInfo;
- if (objc != 3) {
- goto only3Args;
- }
- dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL);
- if (dirPtr == NULL) {
- return TCL_ERROR;
- } else {
- Tcl_SetObjResult(interp, dirPtr);
- Tcl_DecrRefCount(dirPtr);
- return TCL_OK;
- }
+ if (objc != 3) {
+ goto only3Args;
}
- case FCMD_TYPE: {
- Tcl_StatBuf buf;
-
- if (objc != 3) {
- goto only3Args;
- }
- if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- GetTypeFromMode((unsigned short) buf.st_mode), -1));
+ fsInfo = Tcl_FSFileSystemInfo(objv[2]);
+ if (fsInfo != NULL) {
+ Tcl_SetObjResult(interp, fsInfo);
return TCL_OK;
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("Unrecognised path",-1));
+ return TCL_ERROR;
}
- case FCMD_VOLUMES:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_FSListVolumes());
+ }
+ case FCMD_TAIL: {
+ Tcl_Obj *dirPtr;
+
+ if (objc != 3) {
+ goto only3Args;
+ }
+ dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL);
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
+ } else {
+ Tcl_SetObjResult(interp, dirPtr);
+ Tcl_DecrRefCount(dirPtr);
return TCL_OK;
- case FCMD_WRITABLE:
- if (objc != 3) {
- goto only3Args;
- }
- return CheckAccess(interp, objv[2], W_OK);
+ }
+ }
+ case FCMD_TYPE: {
+ Tcl_StatBuf buf;
+
+ if (objc != 3) {
+ goto only3Args;
+ }
+ if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ GetTypeFromMode((unsigned short) buf.st_mode), -1));
+ return TCL_OK;
+ }
+ case FCMD_VOLUMES:
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_FSListVolumes());
+ return TCL_OK;
+ case FCMD_WRITABLE:
+ if (objc != 3) {
+ goto only3Args;
+ }
+ return CheckAccess(interp, objv[2], W_OK);
}
- only3Args:
+ only3Args:
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
@@ -1405,12 +1419,12 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
*
* CheckAccess --
*
- * Utility procedure used by Tcl_FileObjCmd() to query file
- * attributes available through the access() system call.
+ * 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.
+ * 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.
@@ -1420,7 +1434,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
static int
CheckAccess(interp, pathPtr, mode)
- Tcl_Interp *interp; /* Interp for status return. Must not be
+ Tcl_Interp *interp; /* Interp for status return. Must not be
* NULL. */
Tcl_Obj *pathPtr; /* Name of file to check. */
int mode; /* Attribute to check; passed as argument to
@@ -1443,14 +1457,14 @@ CheckAccess(interp, pathPtr, mode)
*
* GetStatBuf --
*
- * Utility procedure used by Tcl_FileObjCmd() to query file
- * attributes available through the stat() or lstat() system call.
+ * 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.
+ * 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.
@@ -1491,13 +1505,13 @@ GetStatBuf(interp, pathPtr, statProc, statPtr)
*
* 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.
+ * 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.
+ * 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.
@@ -1510,8 +1524,8 @@ StoreStatData(interp, varName, statPtr)
Tcl_Interp *interp; /* Interpreter for error reports. */
Tcl_Obj *varName; /* Name of associative array variable
* in which to store stat results. */
- Tcl_StatBuf *statPtr; /* Pointer to buffer containing
- * stat data to store in varName. */
+ Tcl_StatBuf *statPtr; /* Pointer to buffer containing stat
+ * data to store in varName. */
{
Tcl_Obj *field = Tcl_NewObj();
Tcl_Obj *value;
@@ -1520,40 +1534,43 @@ StoreStatData(interp, varName, statPtr)
/*
* Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
*
- * Might be a better idea to call Tcl_SetVar2Ex() instead so we
- * don't have to make assumptions that might go wrong later.
+ * Might be a better idea to call Tcl_SetVar2Ex() instead so we don't have
+ * to make assumptions that might go wrong later.
*/
+
#define STORE_ARY(fieldName, object) \
Tcl_SetStringObj(field, (fieldName), -1); \
value = (object); \
- if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \
+ if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \
Tcl_DecrRefCount(field); \
Tcl_DecrRefCount(value); \
return TCL_ERROR; \
}
Tcl_IncrRefCount(field);
- STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
+
/*
- * Watch out porters; the inode is meant to be an *unsigned* value,
- * so the cast might fail when there isn't a real arithmentic 'long
- * long' type...
+ * Watch out porters; the inode is meant to be an *unsigned* value, so the
+ * cast might fail when there isn't a real arithmentic 'long long' type...
*/
- STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
- STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
- STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid));
- STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid));
- STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
+
+ STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
+ STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
+ STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
+ STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid));
+ STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid));
+ STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_ST_BLOCKS
- STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
+ STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
#endif
- STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime));
- STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime));
- STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime));
+ STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime));
+ STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime));
+ STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime));
mode = (unsigned short) statPtr->st_mode;
- STORE_ARY("mode", Tcl_NewIntObj(mode));
- STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
+ STORE_ARY("mode", Tcl_NewIntObj(mode));
+ STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY
+
Tcl_DecrRefCount(field);
return TCL_OK;
}
@@ -1563,8 +1580,7 @@ StoreStatData(interp, varName, statPtr)
*
* GetTypeFromMode --
*
- * Given a mode word, returns a string identifying the type of a
- * file.
+ * Given a mode word, returns a string identifying the type of a file.
*
* Results:
* A static text string giving the file type from mode.
@@ -1606,44 +1622,44 @@ GetTypeFromMode(mode)
*
* Tcl_ForObjCmd --
*
- * This procedure is invoked to process the "for" Tcl command.
- * See the user documentation for details on what it does.
+ * 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.,
+ * 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.
+ * A standard Tcl result.
*
* Side effects:
- * See the user documentation.
+ * See the user documentation.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
+ /* 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. */
+ 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;
+ 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;
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
+ }
+ return result;
}
while (1) {
/*
@@ -1653,38 +1669,38 @@ Tcl_ForObjCmd(dummy, interp, objc, objv)
*/
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);
+ 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;
- }
+ 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;
+ result = TCL_OK;
}
if (result == TCL_OK) {
- Tcl_ResetResult(interp);
+ Tcl_ResetResult(interp);
}
return result;
}
@@ -1722,10 +1738,10 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
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.
+ * 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
@@ -1752,23 +1768,23 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
/*
- * Create the object argument array "argObjv". Make sure argObjv is
- * large enough to hold the objc arguments.
+ * 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++) {
+ 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]
+ * argvList[i] is a value list counted by argcList[i]l;
+ * 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;
@@ -1788,13 +1804,13 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
/*
- * Break up the value lists and variable lists into elements
+ * Break up the value lists and variable lists into elements.
*/
maxj = 0;
- for (i = 0; i < numLists; i++) {
+ for (i=0 ; i<numLists ; i++) {
result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
- &varcList[i], &varvList[i]);
+ &varcList[i], &varvList[i]);
if (result != TCL_OK) {
goto done;
}
@@ -1805,7 +1821,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
- &argcList[i], &argvList[i]);
+ &argcList[i], &argvList[i]);
if (result != TCL_OK) {
goto done;
}
@@ -1820,20 +1836,19 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
/*
- * Iterate maxj times through the lists in parallel
- * If some value lists run out of values, set loop vars to ""
+ * 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++) {
+ for (j=0 ; j<maxj ; j++) {
+ for (i=0 ; i<numLists ; i++) {
/*
- * Refetch the list members; we assume that the sizes are
- * the same, but the array of elements might be different
- * if the internal rep of the objects has been lost and
- * recreated (it is too difficult to accurately tell when
- * this happens, which can lead to some wierd crashes,
- * like Bug #494348...)
+ * Refetch the list members; we assume that the sizes are the
+ * same, but the array of elements might be different if the
+ * internal rep of the objects has been lost and recreated (it is
+ * too difficult to accurately tell when this happens, which can
+ * lead to some wierd crashes, like Bug #494348...)
*/
result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
@@ -1847,7 +1862,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
}
- for (v = 0; v < varcList[i]; v++) {
+ for (v=0 ; v<varcList[i] ; v++) {
int k = index[i]++;
Tcl_Obj *valuePtr, *varValuePtr;
int isEmptyObj = 0;
@@ -1870,7 +1885,6 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
result = TCL_ERROR;
goto done;
}
-
}
}
@@ -1882,7 +1896,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
result = TCL_OK;
break;
} else if (result == TCL_ERROR) {
- char msg[32 + TCL_INTEGER_SPACE];
+ char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"foreach\" body line %d)",
interp->errorLine);
@@ -1897,7 +1911,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
Tcl_ResetResult(interp);
}
- done:
+ done:
if (numLists > STATIC_LIST_SIZE) {
ckfree((char *) index);
ckfree((char *) varcList);
@@ -1918,8 +1932,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
*
* Tcl_FormatObjCmd --
*
- * This procedure is invoked to process the "format" Tcl command.
- * See the user documentation for details on what it does.
+ * 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.
@@ -1958,8 +1972,8 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
* it's a double value. */
Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if
* it's a 'long long' value. */
- int whichValue; /* Indicates which of intValue, ptrValue,
- * or doubleValue has the value to pass to
+ 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
@@ -1972,14 +1986,15 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
Tcl_Obj *resultPtr; /* Where result is stored finally. */
char staticBuf[MAX_FLOAT_SIZE + 1];
- /* A static buffer to copy the format results
+ /* A static buffer to copy the format results
* into */
- char *dst = staticBuf; /* The buffer that sprintf writes into each
+ 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 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. */
@@ -1999,17 +2014,17 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
int useWide; /* Value to be printed is Tcl_WideInt. */
/*
- * This procedure is a bit nasty. The goal is to use sprintf to
- * do most of the dirty work. There are several problems:
+ * 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
- * and wide-ints).
- * So, what happens here is to scan the format string one % group
- * at a time, making many individual calls to sprintf.
+ * 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 and
+ * wide-ints).
+ * So, what happens here is to scan the format string one % group at a
+ * time, making many individual calls to sprintf.
*/
if (objc < 2) {
@@ -2033,6 +2048,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
/*
* Get rid of any characters before the next field specifier.
*/
+
if (*format != '%') {
ptrValue = format;
while ((*format != '%') && (format < endPtr)) {
@@ -2052,10 +2068,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
}
/*
- * Parse off a field specifier, compute how many characters
- * will be needed to store the result, and substitute for
- * "*" size specifiers.
+ * Parse off a field specifier, compute how many characters will be
+ * needed to store the result, and substitute for "*" size specifiers.
*/
+
*newPtr = '%';
newPtr++;
format++;
@@ -2063,9 +2079,9 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
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.
+ * 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. */
@@ -2084,13 +2100,13 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
goto xpgCheckDone;
}
- notXpg:
+ notXpg:
gotSequential = 1;
if (gotXpg) {
goto mixedXPG;
}
- xpgCheckDone:
+ xpgCheckDone:
while ((*format == '-') || (*format == '#') || (*format == '0')
|| (*format == ' ') || (*format == '+')) {
if (*format == '-') {
@@ -2098,9 +2114,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
}
if (*format == '0') {
/*
- * This will be handled by sprintf for numbers, but we
- * need to do the char/string ones ourselves
+ * This will be handled by sprintf for numbers, but we need to
+ * do the char/string ones ourselves.
*/
+
gotZero = 1;
}
*newPtr = *format;
@@ -2129,9 +2146,8 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
}
if (width > 100000) {
/*
- * Don't allow arbitrarily large widths: could cause core
- * dump when we try to allocate a zillion bytes of memory
- * below.
+ * Don't allow arbitrarily large widths: could cause core dump
+ * when we try to allocate a zillion bytes of memory below.
*/
width = 100000;
@@ -2172,10 +2188,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
}
if (*format == 'l') {
useWide = 1;
+
/*
- * Only add a 'll' modifier for integer values as it makes
- * some libc's go into spasm otherwise. [Bug #702622]
+ * Only add a 'll' modifier for integer values as it makes some
+ * libc's go into spasm otherwise. [Bug #702622]
*/
+
switch (format[1]) {
case 'i':
case 'd':
@@ -2223,15 +2241,16 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
#if (LONG_MAX > INT_MAX)
if (!useShort) {
/*
- * Add the 'l' for long format type because we are on an
- * LP64 archtecture and we are really going to pass a long
- * argument to sprintf.
+ * Add the 'l' for long format type because we are on an LP64
+ * archtecture and we are really going to pass a long argument
+ * to sprintf.
*
- * Do not add this if we're going to pass in a short (i.e.
- * if we've got an 'h' modifier already in the string); some
- * libc implementations of sprintf() do not like it at all.
- * [Bug 1154163]
+ * Do not add this if we're going to pass in a short (i.e. if
+ * we've got an 'h' modifier already in the string); some libc
+ * implementations of sprintf() do not like it at all. [Bug
+ * 1154163]
*/
+
newPtr++;
*newPtr = 0;
newPtr[-1] = newPtr[-2];
@@ -2243,10 +2262,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
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.
+ * 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;
@@ -2273,7 +2292,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
case 'f':
case 'g':
case 'G':
- if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
+ if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &doubleValue) != TCL_OK) {
goto fmtError;
}
@@ -2301,11 +2320,11 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
format++;
/*
- * Make sure that there's enough space to hold the formatted
- * result, then format it.
+ * Make sure that there's enough space to hold the formatted result,
+ * then format it.
*/
- doField:
+ doField:
if (width > size) {
size = width;
}
@@ -2313,7 +2332,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
Tcl_AppendToObj(resultPtr, ptrValue, size);
} else {
if (size > dstSize) {
- if (dst != staticBuf) {
+ if (dst != staticBuf) {
ckfree(dst);
}
dst = (char *) ckalloc((unsigned) (size + 1));
@@ -2368,7 +2387,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
}
}
- size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
+ size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
if (size) {
memcpy(ptr, ptrValue, (size_t) size);
ptr += size;
@@ -2394,24 +2413,32 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
}
return TCL_OK;
- mixedXPG:
- Tcl_SetResult(interp,
+ mixedXPG:
+ Tcl_SetResult(interp,
"cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
goto fmtError;
- badIndex:
+ badIndex:
if (gotXpg) {
- Tcl_SetResult(interp,
+ Tcl_SetResult(interp,
"\"%n$\" argument index out of range", TCL_STATIC);
} else {
- Tcl_SetResult(interp,
+ Tcl_SetResult(interp,
"not enough arguments for all format specifiers", TCL_STATIC);
}
- fmtError:
+ fmtError:
if (dst != staticBuf) {
ckfree(dst);
}
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */