diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2005-07-24 22:56:43 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2005-07-24 22:56:43 (GMT) |
commit | 88304e7e4a0cf2399fa92d3a6ccfa127603299fa (patch) | |
tree | c7a85f1ac9bc772319495b8648b9347ddbcf0e96 /generic | |
parent | 7bc20e13c9c5f3706c7f50ae52ff329de08f8782 (diff) | |
download | tcl-88304e7e4a0cf2399fa92d3a6ccfa127603299fa.zip tcl-88304e7e4a0cf2399fa92d3a6ccfa127603299fa.tar.gz tcl-88304e7e4a0cf2399fa92d3a6ccfa127603299fa.tar.bz2 |
Getting more systematic about style
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclConfig.c | 256 | ||||
-rw-r--r-- | generic/tclFCmd.c | 615 | ||||
-rw-r--r-- | generic/tclGet.c | 80 | ||||
-rw-r--r-- | generic/tclPreserve.c | 272 | ||||
-rw-r--r-- | generic/tclResult.c | 541 | ||||
-rw-r--r-- | generic/tclStringObj.c | 995 | ||||
-rwxr-xr-x | generic/tclThreadAlloc.c | 194 | ||||
-rw-r--r-- | generic/tclTimer.c | 596 | ||||
-rw-r--r-- | generic/tclUtil.c | 1486 |
9 files changed, 2607 insertions, 2428 deletions
diff --git a/generic/tclConfig.c b/generic/tclConfig.c index f9c6dda..49eb04b 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -1,4 +1,4 @@ -/* +/* * tclConfig.c -- * * This file provides the facilities which allow Tcl and other packages @@ -6,10 +6,10 @@ * * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclConfig.c,v 1.8 2005/05/10 18:34:28 kennykb Exp $ + * RCS: @(#) $Id: tclConfig.c,v 1.9 2005/07/24 22:56:43 dkf Exp $ */ #include "tclInt.h" @@ -19,13 +19,12 @@ /* * Internal structure to hold embedded configuration information. * - * Our structure is a two-level dictionary associated with the - * 'interp'. The first level is keyed with the package name and maps - * to the dictionary for that package. The package dictionary is keyed - * with metadata keys and maps to the metadata value for that - * key. This is package specific. The metadata values are in UTF8, - * converted from the external representation given to us by the - * caller. + * Our structure is a two-level dictionary associated with the 'interp'. The + * first level is keyed with the package name and maps to the dictionary for + * that package. The package dictionary is keyed with metadata keys and maps + * to the metadata value for that key. This is package specific. The metadata + * values are in UTF-8, converted from the external representation given to us + * by the caller. */ #define ASSOC_KEY "tclPackageAboutDict" @@ -34,26 +33,20 @@ * Static functions in this file: */ -static int -QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); - -static void -QueryConfigDelete _ANSI_ARGS_((ClientData clientData)); - -static Tcl_Obj* -GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp)); - -static void -ConfigDictDeleteProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); +static int QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + struct Tcl_Obj * CONST * objv)); +static void QueryConfigDelete _ANSI_ARGS_((ClientData clientData)); +static Tcl_Obj * GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp)); +static void ConfigDictDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); /* *---------------------------------------------------------------------- * * Tcl_RegisterConfig -- * - * See TIP#59 for details on what this procedure does. + * See TIP#59 for details on what this function does. * * Results: * None. @@ -65,110 +58,108 @@ ConfigDictDeleteProc _ANSI_ARGS_((ClientData clientData, */ void -Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding) - Tcl_Interp* interp; /* Interpreter the configuration - * command is registered in. */ - CONST char* pkgName; /* Name of the package registering - * the embedded configuration. ASCII, - * thus in UTF-8 too. */ - Tcl_Config* configuration; /* Embedded configuration */ - CONST char* valEncoding; /* Name of the encoding used to - * store the configuration values, - * ASCII, thus UTF-8 */ +Tcl_RegisterConfig(interp, pkgName, configuration, valEncoding) + Tcl_Interp *interp; /* Interpreter the configuration command is + * registered in. */ + CONST char *pkgName; /* Name of the package registering the + * embedded configuration. ASCII, thus in + * UTF-8 too. */ + Tcl_Config *configuration; /* Embedded configuration. */ + CONST char *valEncoding; /* Name of the encoding used to store the + * configuration values, ASCII, thus UTF-8. */ { - Tcl_Encoding venc = Tcl_GetEncoding (NULL, valEncoding); - Tcl_Obj* pDB = GetConfigDict (interp); - Tcl_Obj* pkg = Tcl_NewStringObj (pkgName, -1); - Tcl_Obj* pkgDict; - Tcl_DString cmdName; - Tcl_Config* cfg; - int res; + Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); + Tcl_Obj *pDB = GetConfigDict(interp); + Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1); + Tcl_Obj *pkgDict; + Tcl_DString cmdName; + Tcl_Config *cfg; + int res; /* - * Phase I: Adding the provided information to the internal - * database of package meta data. + * Phase I: Adding the provided information to the internal database of + * package meta data. * - * Phase II: Create a command for querying this database, specific - * to the package registerting its configuration. This is the - * approved interface in TIP 59. In the future a more general - * interface should be done, as followup to TIP 59. Simply because - * our database is now general across packages, and not a - * structure tied to one package. + * Phase II: Create a command for querying this database, specific to the + * package registerting its configuration. This is the approved interface + * in TIP 59. In the future a more general interface should be done, as + * followup to TIP 59. Simply because our database is now general across + * packages, and not a structure tied to one package. + * + * Note, the created command will have a reference through its clientdata. */ - /* Note, the created command will have a reference through its clientdata */ - Tcl_IncrRefCount (pkg); + Tcl_IncrRefCount(pkg); - /* Retrieve package specific configuration ... */ + /* + * Retrieve package specific configuration... + */ - res = Tcl_DictObjGet (interp, pDB, pkg, &pkgDict); + res = Tcl_DictObjGet(interp, pDB, pkg, &pkgDict); if ((TCL_OK != res) || (pkgDict == NULL)) { - pkgDict = Tcl_NewDictObj (); - } else if (Tcl_IsShared (pkgDict)) { - pkgDict = Tcl_DuplicateObj (pkgDict); + pkgDict = Tcl_NewDictObj(); + } else if (Tcl_IsShared(pkgDict)) { + pkgDict = Tcl_DuplicateObj(pkgDict); } - /* Extend the package configuration ... */ - - for (cfg = configuration; - (cfg->key != (CONST char*) NULL) && (cfg->key [0] != '\0') ; - cfg++) { + /* + * Extend the package configuration... + */ + for (cfg=configuration ; (cfg->key!=NULL) && (cfg->key[0]!='\0') ; cfg++) { Tcl_DString conv; - CONST char* convValue = Tcl_ExternalToUtfDString (venc, cfg->value, -1, &conv); + CONST char *convValue = + Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv); /* * We know that the keys are in ASCII/UTF-8, so for them is no * conversion required. */ - Tcl_DictObjPut (interp, pkgDict, - Tcl_NewStringObj (cfg->key, -1), - Tcl_NewStringObj (convValue, -1)); - Tcl_DStringFree (&conv); + Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), + Tcl_NewStringObj(convValue, -1)); + Tcl_DStringFree(&conv); } - /* Write the changes back into the overall database */ + /* + * Write the changes back into the overall database. + */ - Tcl_DictObjPut (interp, pDB, pkg, pkgDict); + Tcl_DictObjPut(interp, pDB, pkg, pkgDict); /* * Now create the interface command for retrieval of the package * information. */ - Tcl_DStringInit (&cmdName); - Tcl_DStringAppend (&cmdName, "::", -1); - Tcl_DStringAppend (&cmdName, pkgName, -1); + Tcl_DStringInit(&cmdName); + Tcl_DStringAppend(&cmdName, "::", -1); + Tcl_DStringAppend(&cmdName, pkgName, -1); - /* The incomplete command name is the name of the namespace to - * place it in. + /* + * The incomplete command name is the name of the namespace to place it + * in. */ - if ((Tcl_Namespace*) NULL == Tcl_FindNamespace(interp, - Tcl_DStringValue (&cmdName), NULL, TCL_GLOBAL_ONLY)) { - - if ((Tcl_Namespace*) NULL == Tcl_CreateNamespace (interp, - Tcl_DStringValue (&cmdName), (ClientData) NULL, - (Tcl_NamespaceDeleteProc *) NULL)) { - - Tcl_Panic ("%s.\n%s %s", Tcl_GetStringResult(interp), + if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL, + TCL_GLOBAL_ONLY) == NULL) { + if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName), + (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL) == NULL) { + Tcl_Panic("%s.\n%s %s", Tcl_GetStringResult(interp), "Tcl_RegisterConfig: Unable to create namespace for", "package configuration."); } } - Tcl_DStringAppend (&cmdName, "::pkgconfig", -1); + Tcl_DStringAppend(&cmdName, "::pkgconfig", -1); - if ((Tcl_Command) NULL == Tcl_CreateObjCommand (interp, - Tcl_DStringValue (&cmdName), QueryConfigObjCmd, - (ClientData) pkg, QueryConfigDelete)) { - - Tcl_Panic ("%s %s", "Tcl_RegisterConfig: Unable to create query", + if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), + QueryConfigObjCmd, (ClientData) pkg, QueryConfigDelete) == NULL) { + Tcl_Panic("%s %s", "Tcl_RegisterConfig: Unable to create query", "command for package configuration"); } - Tcl_DStringFree (&cmdName); + Tcl_DStringFree(&cmdName); } /* @@ -190,16 +181,14 @@ Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding) static int QueryConfigObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - struct Tcl_Obj * CONST *objv; + ClientData clientData; + Tcl_Interp *interp; + int objc; + struct Tcl_Obj * CONST *objv; { - Tcl_Obj *pkgName = (Tcl_Obj*) clientData; + Tcl_Obj *pkgName = (Tcl_Obj *) clientData; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - Tcl_DictSearch s; - int n, i, res, done, index; - Tcl_Obj *key, **vals; + int n, i, res, index; static CONST char *subcmdStrings[] = { "get", "list", NULL @@ -212,15 +201,19 @@ QueryConfigObjCmd(clientData, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, - "subcommand", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0, + &index) != TCL_OK) { return TCL_ERROR; } pDB = GetConfigDict(interp); res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict); if (res!=TCL_OK || pkgDict==NULL) { - /* Maybe a Tcl_Panic is better, because the package data has to be present */ + /* + * Maybe a Tcl_Panic is better, because the package data has to be + * present. + */ + Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); return TCL_ERROR; } @@ -249,16 +242,19 @@ QueryConfigObjCmd(clientData, interp, objc, objv) Tcl_DictObjSize(interp, pkgDict, &n); listPtr = Tcl_NewListObj(n, NULL); - + if (!listPtr) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("insufficient memory to create list", -1)); + Tcl_NewStringObj("insufficient memory to create list",-1)); return TCL_ERROR; } - + if (n) { - List *listRepPtr = - (List *) listPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = (List *) + listPtr->internalRep.twoPtrValue.ptr1; + Tcl_DictSearch s; + Tcl_Obj *key, **vals; + int done; listRepPtr->elemCount = n; vals = &listRepPtr->elements; @@ -285,7 +281,7 @@ QueryConfigObjCmd(clientData, interp, objc, objv) * * QueryConfigDelete -- * - * Command delete procedure. Cleans up after the configuration query + * Command delete function. Cleans up after the configuration query * command when it is deleted by the user or during finalization. * * Results: @@ -298,11 +294,11 @@ QueryConfigObjCmd(clientData, interp, objc, objv) */ static void -QueryConfigDelete (clientData) - ClientData clientData; +QueryConfigDelete(clientData) + ClientData clientData; { - Tcl_Obj* pkgName = (Tcl_Obj*) clientData; - Tcl_DecrRefCount (pkgName); + Tcl_Obj *pkgName = (Tcl_Obj *) clientData; + Tcl_DecrRefCount(pkgName); } /* @@ -322,19 +318,19 @@ QueryConfigDelete (clientData) *------------------------------------------------------------------------- */ -static Tcl_Obj* -GetConfigDict (interp) - Tcl_Interp* interp; +static Tcl_Obj * +GetConfigDict(interp) + Tcl_Interp *interp; { - Tcl_Obj* pDB = Tcl_GetAssocData (interp, ASSOC_KEY, NULL); + Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL); - if (pDB == (Tcl_Obj*) NULL) { - pDB = Tcl_NewDictObj (); - Tcl_IncrRefCount (pDB); - Tcl_SetAssocData (interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); - } + if (pDB == (Tcl_Obj *) NULL) { + pDB = Tcl_NewDictObj(); + Tcl_IncrRefCount(pDB); + Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); + } - return pDB; + return pDB; } /* @@ -342,10 +338,10 @@ GetConfigDict (interp) * * ConfigDictDeleteProc -- * - * This procedure is associated with the "Package About dict" assoc data - * for an interpreter; it is invoked when the interpreter is - * deleted in order to free the information assoicated with any - * pending error reports. + * This function is associated with the "Package About dict" assoc data + * for an interpreter; it is invoked when the interpreter is deleted in + * order to free the information assoicated with any pending error + * reports. * * Results: * None. @@ -361,6 +357,14 @@ ConfigDictDeleteProc(clientData, interp) ClientData clientData; /* Pointer to Tcl_Obj. */ Tcl_Interp *interp; /* Interpreter being deleted. */ { - Tcl_Obj* pDB = (Tcl_Obj*) clientData; - Tcl_DecrRefCount (pDB); + Tcl_Obj *pDB = (Tcl_Obj *) clientData; + Tcl_DecrRefCount(pDB); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index d5e7005..3c79e85 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1,25 +1,25 @@ /* * tclFCmd.c * - * This file implements the generic portion of file manipulation - * subcommands of the "file" command. + * This file implements the generic portion of file manipulation + * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.34 2005/06/13 08:32:05 vincentdarley Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.35 2005/07/24 22:56:43 dkf Exp $ */ #include "tclInt.h" /* - * Declarations for local procedures defined in this file: + * Declarations for local functions defined in this file: */ static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, + Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, int copyFlag, int force)); static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); @@ -33,10 +33,10 @@ static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, * * TclFileRenameCmd * - * This procedure implements the "rename" subcommand of the "file" - * command. Filename arguments need to be translated to native - * format before being passed to platform-specific code that - * implements rename functionality. + * This function implements the "rename" subcommand of the "file" + * command. Filename arguments need to be translated to native format + * before being passed to platform-specific code that implements rename + * functionality. * * Results: * A standard Tcl result. @@ -61,10 +61,9 @@ TclFileRenameCmd(interp, objc, objv) * * TclFileCopyCmd * - * This procedure implements the "copy" subcommand of the "file" - * command. Filename arguments need to be translated to native - * format before being passed to platform-specific code that - * implements copy functionality. + * This function implements the "copy" subcommand of the "file" command. + * Filename arguments need to be translated to native format before being + * passed to platform-specific code that implements copy functionality. * * Results: * A standard Tcl result. @@ -89,8 +88,8 @@ TclFileCopyCmd(interp, objc, objv) * * FileCopyRename -- * - * Performs the work of TclFileRenameCmd and TclFileCopyCmd. - * See comments for those procedures. + * Performs the work of TclFileRenameCmd and TclFileCopyCmd. See + * comments for those functions. * * Results: * See above. @@ -106,11 +105,11 @@ FileCopyRename(interp, objc, objv, copyFlag) Tcl_Interp *interp; /* Used for error reporting. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ - int copyFlag; /* If non-zero, copy source(s). Otherwise, + int copyFlag; /* If non-zero, copy source(s). Otherwise, * rename them. */ { int i, result, force; - Tcl_StatBuf statBuf; + Tcl_StatBuf statBuf; Tcl_Obj *target; i = FileForceOption(interp, objc - 2, objv + 2, &force); @@ -119,9 +118,9 @@ FileCopyRename(interp, objc, objv, copyFlag) } i += 2; if ((objc - i) < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), - " ?options? source ?source ...? target\"", + Tcl_AppendResult(interp, "wrong # args: should be \"", + TclGetString(objv[0]), " ", TclGetString(objv[1]), + " ?options? source ?source ...? target\"", (char *) NULL); return TCL_ERROR; } @@ -151,14 +150,14 @@ FileCopyRename(interp, objc, objv, copyFlag) Tcl_PosixError(interp); Tcl_AppendResult(interp, "error ", ((copyFlag) ? "copying" : "renaming"), ": target \"", - Tcl_GetString(target), "\" is not a directory", + TclGetString(target), "\" is not a directory", (char *) NULL); result = TCL_ERROR; } else { /* - * Even though already have target == translated(objv[i+1]), - * pass the original argument down, so if there's an error, the - * error message will reflect the original arguments. + * Even though already have target == translated(objv[i+1]), pass + * the original argument down, so if there's an error, the error + * message will reflect the original arguments. */ result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag, @@ -166,17 +165,17 @@ FileCopyRename(interp, objc, objv, copyFlag) } return result; } - + /* - * Move each source file into target directory. Extract the basename - * from each source, and append it to the end of the target path. + * Move each source file into target directory. Extract the basename from + * each source, and append it to the end of the target path. */ - for ( ; i < objc - 1; i++) { + for ( ; i<objc-1 ; i++) { Tcl_Obj *jargv[2]; Tcl_Obj *source, *newFileName; Tcl_Obj *temp; - + source = FileBasename(interp, objv[i]); if (source == NULL) { result = TCL_ERROR; @@ -205,10 +204,9 @@ FileCopyRename(interp, objc, objv, copyFlag) * * TclFileMakeDirsCmd * - * This procedure implements the "mkdir" subcommand of the "file" - * command. Filename arguments need to be translated to native - * format before being passed to platform-specific code that - * implements mkdir functionality. + * This function implements the "mkdir" subcommand of the "file" command. + * Filename arguments need to be translated to native format before being + * passed to platform-specific code that implements mkdir functionality. * * Results: * A standard Tcl result. @@ -249,10 +247,10 @@ TclFileMakeDirsCmd(interp, objc, objv) for (j = 0; j < pobjc; j++) { target = Tcl_FSJoinPath(split, j + 1); Tcl_IncrRefCount(target); + /* - * Call Tcl_FSStat() so that if target is a symlink that - * points to a directory we will create subdirectories in - * that directory. + * Call Tcl_FSStat() so that if target is a symlink that points to + * a directory we will create subdirectories in that directory. */ if (Tcl_FSStat(target, &statBuf) == 0) { @@ -262,26 +260,28 @@ TclFileMakeDirsCmd(interp, objc, objv) goto done; } } else if (errno != ENOENT) { - /* - * If Tcl_FSStat() failed and the error is anything - * other than non-existence of the target, throw the - * error. + /* + * If Tcl_FSStat() failed and the error is anything other than + * non-existence of the target, throw the error. */ + errfile = target; goto done; } else if (Tcl_FSCreateDirectory(target) != TCL_OK) { - /* + /* * Create might have failed because of being in a race - * condition with another process trying to create the - * same subdirectory. + * condition with another process trying to create the same + * subdirectory. */ + if (errno == EEXIST) { if ((Tcl_FSStat(target, &statBuf) == 0) - && S_ISDIR(statBuf.st_mode)) { - /* - * It is a directory that wasn't there before, - * so keep going without error. + && S_ISDIR(statBuf.st_mode)) { + /* + * It is a directory that wasn't there before, so keep + * going without error. */ + Tcl_ResetResult(interp); } else { errfile = target; @@ -292,19 +292,22 @@ TclFileMakeDirsCmd(interp, objc, objv) goto done; } } - - /* Forget about this sub-path */ + + /* + * Forget about this sub-path. + */ + Tcl_DecrRefCount(target); target = NULL; } Tcl_DecrRefCount(split); split = NULL; } - - done: + + done: if (errfile != NULL) { Tcl_AppendResult(interp, "can't create directory \"", - Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp), + TclGetString(errfile), "\": ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; } @@ -322,8 +325,8 @@ TclFileMakeDirsCmd(interp, objc, objv) * * TclFileDeleteCmd * - * This procedure implements the "delete" subcommand of the "file" - * command. + * This function implements the "delete" subcommand of the "file" + * command. * * Results: * A standard Tcl result. @@ -343,15 +346,15 @@ TclFileDeleteCmd(interp, objc, objv) int i, force, result; Tcl_Obj *errfile; Tcl_Obj *errorBuffer = NULL; - + i = FileForceOption(interp, objc - 2, objv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; if ((objc - i) < 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), + Tcl_AppendResult(interp, "wrong # args: should be \"", + TclGetString(objv[0]), " ", TclGetString(objv[1]), " ?options? file ?file ...?\"", (char *) NULL); return TCL_ERROR; } @@ -374,34 +377,39 @@ TclFileDeleteCmd(interp, objc, objv) if (Tcl_FSLstat(objv[i], &statBuf) != 0) { /* - * Trying to delete a file that does not exist is not - * considered an error, just a no-op + * Trying to delete a file that does not exist is not considered + * an error, just a no-op */ if (errno != ENOENT) { result = TCL_ERROR; } } else if (S_ISDIR(statBuf.st_mode)) { - /* - * We own a reference count on errorBuffer, if it was set - * as a result of this call. + /* + * We own a reference count on errorBuffer, if it was set as a + * result of this call. */ + result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { - Tcl_AppendResult(interp, "error deleting \"", - Tcl_GetString(objv[i]), - "\": directory not empty", (char *) NULL); + Tcl_AppendResult(interp, "error deleting \"", + TclGetString(objv[i]), "\": directory not empty", + (char *) NULL); Tcl_PosixError(interp); goto done; } - /* + /* * If possible, use the untranslated name for the file. */ - + errfile = errorBuffer; - /* FS supposed to check between translated objv and errfile */ + + /* + * FS supposed to check between translated objv and errfile. + */ + if (Tcl_FSEqualPaths(objv[i], errfile)) { errfile = objv[i]; } @@ -409,32 +417,34 @@ TclFileDeleteCmd(interp, objc, objv) } else { result = Tcl_FSDeleteFile(objv[i]); } - + if (result != TCL_OK) { result = TCL_ERROR; - /* - * It is important that we break on error, otherwise we - * might end up owning reference counts on numerous - * errorBuffers. + + /* + * It is important that we break on error, otherwise we might end + * up owning reference counts on numerous errorBuffers. */ + break; } } if (result != TCL_OK) { if (errfile == NULL) { - /* - * We try to accomodate poor error results from our - * Tcl_FS calls + /* + * We try to accomodate poor error results from our Tcl_FS calls. */ - Tcl_AppendResult(interp, "error deleting unknown file: ", + + Tcl_AppendResult(interp, "error deleting unknown file: ", Tcl_PosixError(interp), (char *) NULL); } else { - Tcl_AppendResult(interp, "error deleting \"", - Tcl_GetString(errfile), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_AppendResult(interp, "error deleting \"", + TclGetString(errfile), "\": ", Tcl_PosixError(interp), + (char *) NULL); } - } - done: + } + + done: if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); } @@ -446,37 +456,37 @@ TclFileDeleteCmd(interp, objc, objv) * * CopyRenameOneFile * - * Copies or renames specified source file or directory hierarchy - * to the specified target. + * Copies or renames specified source file or directory hierarchy to the + * specified target. * * Results: * A standard Tcl result. * * Side effects: - * Target is overwritten if the force flag is set. Attempting to - * copy/rename a file onto a directory or a directory onto a file - * will always result in an error. + * Target is overwritten if the force flag is set. Attempting to + * copy/rename a file onto a directory or a directory onto a file will + * always result in an error. * *---------------------------------------------------------------------- */ static int -CopyRenameOneFile(interp, source, target, copyFlag, force) +CopyRenameOneFile(interp, source, target, copyFlag, force) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Obj *source; /* Pathname of file to copy. May need to - * be translated. */ - Tcl_Obj *target; /* Pathname of file to create/overwrite. - * May need to be translated. */ - int copyFlag; /* If non-zero, copy files. Otherwise, - * rename them. */ + Tcl_Obj *source; /* Pathname of file to copy. May need to be + * translated. */ + Tcl_Obj *target; /* Pathname of file to create/overwrite. May + * need to be translated. */ + int copyFlag; /* If non-zero, copy files. Otherwise, rename + * them. */ int force; /* If non-zero, overwrite target file if it - * exists. Otherwise, error if target already + * exists. Otherwise, error if target already * exists. */ { int result; Tcl_Obj *errfile, *errorBuffer; - /* If source is a link, then this is the real file/directory */ - Tcl_Obj *actualSource = NULL; + Tcl_Obj *actualSource=NULL; /* If source is a link, then this is the real + * file/directory. */ Tcl_StatBuf sourceStatBuf, targetStatBuf; if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { @@ -485,16 +495,15 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } - + errfile = NULL; errorBuffer = NULL; result = TCL_ERROR; - + /* - * We want to copy/rename links and not the files they point to, so we - * use lstat(). If target is a link, we also want to replace the - * link and not the file it points to, so we also use lstat() on the - * target. + * We want to copy/rename links and not the files they point to, so we use + * lstat(). If target is a link, we also want to replace the link and not + * the file it points to, so we also use lstat() on the target. */ if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { @@ -513,52 +522,52 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) goto done; } - /* - * Prevent copying or renaming a file onto itself. Under Windows, - * stat always returns 0 for st_ino. However, the Windows-specific - * code knows how to deal with copying or renaming a file on top of - * itself. It might be a good idea to write a stat that worked. - */ - - if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { - if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && - (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { - result = TCL_OK; - goto done; - } - } + /* + * Prevent copying or renaming a file onto itself. Under Windows, stat + * always returns 0 for st_ino. However, the Windows-specific code + * knows how to deal with copying or renaming a file on top of itself. + * It might be a good idea to write a stat that worked. + */ + + if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { + if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && + (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { + result = TCL_OK; + goto done; + } + } /* - * Prevent copying/renaming a file onto a directory and - * vice-versa. This is a policy decision based on the fact that - * existing implementations of copy and rename on all platforms - * also prevent this. + * Prevent copying/renaming a file onto a directory and vice-versa. + * This is a policy decision based on the fact that existing + * implementations of copy and rename on all platforms also prevent + * this. */ if (S_ISDIR(sourceStatBuf.st_mode) - && !S_ISDIR(targetStatBuf.st_mode)) { + && !S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite file \"", - Tcl_GetString(target), "\" with directory \"", - Tcl_GetString(source), "\"", (char *) NULL); + Tcl_AppendResult(interp, "can't overwrite file \"", + TclGetString(target), "\" with directory \"", + TclGetString(source), "\"", (char *) NULL); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) - && S_ISDIR(targetStatBuf.st_mode)) { + && S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite directory \"", - Tcl_GetString(target), "\" with file \"", - Tcl_GetString(source), "\"", (char *) NULL); + Tcl_AppendResult(interp, "can't overwrite directory \"", + TclGetString(target), "\" with file \"", + TclGetString(source), "\"", (char *) NULL); goto done; } - - /* - * The destination exists, but appears to be ok to over-write, - * and -force is given. We now try to adjust permissions to - * ensure the operation succeeds. If we can't adjust - * permissions, we'll let the actual copy/rename return - * an error later. + + /* + * The destination exists, but appears to be ok to over-write, and + * -force is given. We now try to adjust permissions to ensure the + * operation succeeds. If we can't adjust permissions, we'll let the + * actual copy/rename return an error later. */ + { Tcl_Obj* perm = Tcl_NewStringObj("u+w",-1); int index; @@ -575,68 +584,76 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) if (result == TCL_OK) { goto done; } - + if (errno == EINVAL) { - Tcl_AppendResult(interp, "error renaming \"", - Tcl_GetString(source), "\" to \"", - Tcl_GetString(target), "\": trying to rename a volume or ", + Tcl_AppendResult(interp, "error renaming \"", + TclGetString(source), "\" to \"", TclGetString(target), + "\": trying to rename a volume or ", "move a directory into itself", (char *) NULL); goto done; } else if (errno != EXDEV) { errfile = target; goto done; } - + /* - * The rename failed because the move was across file systems. - * Fall through to copy file and then remove original. Note that - * the low-level Tcl_FSRenameFileProc in the filesystem is allowed - * to implement cross-filesystem moves itself, if it desires. + * The rename failed because the move was across file systems. Fall + * through to copy file and then remove original. Note that the + * low-level Tcl_FSRenameFileProc in the filesystem is allowed to + * implement cross-filesystem moves itself, if it desires. */ } actualSource = source; Tcl_IncrRefCount(actualSource); - /* - * Activate the following block to copy files instead of links. - * However Tcl's semantics currently say we should copy links, so - * any such change should be the subject of careful study on - * the consequences. - * - * Perhaps there could be an optional flag to 'file copy' to - * dictate which approach to use, with the default being _not_ - * to have this block active. + + /* + * Activate the following block to copy files instead of links. However + * Tcl's semantics currently say we should copy links, so any such change + * should be the subject of careful study on the consequences. + * + * Perhaps there could be an optional flag to 'file copy' to dictate which + * approach to use, with the default being _not_ to have this block + * active. */ + #if 0 #ifdef S_ISLNK if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) { - /* - * We want to copy files not links. Therefore we must follow the - * link. There are two purposes to this 'stat' call here. First - * we want to know if the linked-file/dir actually exists, and - * second, in the block of code which follows, some 20 lines - * down, we want to check if the thing is a file or directory. + /* + * We want to copy files not links. Therefore we must follow the link. + * There are two purposes to this 'stat' call here. First we want to + * know if the linked-file/dir actually exists, and second, in the + * block of code which follows, some 20 lines down, we want to check + * if the thing is a file or directory. */ + if (Tcl_FSStat(source, &sourceStatBuf) != 0) { - /* Actual file doesn't exist */ - Tcl_AppendResult(interp, - "error copying \"", Tcl_GetString(source), + /* + * Actual file doesn't exist. + */ + + Tcl_AppendResult(interp, "error copying \"", TclGetString(source), "\": the target of this link doesn't exist", (char *) NULL); goto done; } else { int counter = 0; + while (1) { Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0); if (path == NULL) { break; } - /* - * Now we want to check if this is a relative path, - * and if so, to make it absolute + + /* + * Now we want to check if this is a relative path, and if so, + * to make it absolute. */ + if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) { Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path); + if (abs == NULL) { break; } @@ -647,9 +664,16 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) Tcl_DecrRefCount(actualSource); actualSource = path; counter++; - /* Arbitrary limit of 20 links to follow */ + + /* + * Arbitrary limit of 20 links to follow. + */ + if (counter > 20) { - /* Too many links */ + /* + * Too many links. + */ + Tcl_SetErrno(EMLINK); errfile = source; goto done; @@ -665,33 +689,34 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer); if (result != TCL_OK) { if (errno == EXDEV) { - /* + /* * The copy failed because we're trying to do a - * cross-filesystem copy. We do this through our Tcl - * library. + * cross-filesystem copy. We do this through our Tcl library. */ + Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL); Tcl_IncrRefCount(copyCommand); - Tcl_ListObjAppendElement(interp, copyCommand, + Tcl_ListObjAppendElement(interp, copyCommand, Tcl_NewStringObj("::tcl::CopyDirectory",-1)); if (copyFlag) { - Tcl_ListObjAppendElement(interp, copyCommand, - Tcl_NewStringObj("copying",-1)); + Tcl_ListObjAppendElement(interp, copyCommand, + Tcl_NewStringObj("copying",-1)); } else { - Tcl_ListObjAppendElement(interp, copyCommand, - Tcl_NewStringObj("renaming",-1)); + Tcl_ListObjAppendElement(interp, copyCommand, + Tcl_NewStringObj("renaming",-1)); } Tcl_ListObjAppendElement(interp, copyCommand, source); Tcl_ListObjAppendElement(interp, copyCommand, target); - result = Tcl_EvalObjEx(interp, copyCommand, - TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + result = Tcl_EvalObjEx(interp, copyCommand, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); Tcl_DecrRefCount(copyCommand); if (result != TCL_OK) { - /* - * There was an error in the Tcl-level copy. - * We will pass on the Tcl error message and - * can ensure this by setting errfile to NULL + /* + * There was an error in the Tcl-level copy. We will pass + * on the Tcl error message and can ensure this by setting + * errfile to NULL */ + errfile = NULL; } } else { @@ -709,19 +734,22 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) result = TclCrossFilesystemCopy(interp, source, target); } if (result != TCL_OK) { - /* - * We could examine 'errno' to double-check if the problem - * was with the target, but we checked the source above, - * so it should be quite clear + /* + * We could examine 'errno' to double-check if the problem was + * with the target, but we checked the source above, so it should + * be quite clear */ + errfile = target; - /* - * We now need to reset the result, because the above call, - * if it failed, may have put an error message in place. - * (Ideally we would prefer not to pass an interpreter in - * above, but the channel IO code used by - * TclCrossFilesystemCopy currently requires one) + + /* + * We now need to reset the result, because the above call, if it + * failed, may have put an error message in place. (Ideally we + * would prefer not to pass an interpreter in above, but the + * channel IO code used by TclCrossFilesystemCopy currently + * requires one). */ + Tcl_ResetResult(interp); } } @@ -740,31 +768,30 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) } } if (result != TCL_OK) { - Tcl_AppendResult(interp, "can't unlink \"", - Tcl_GetString(errfile), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile), + "\": ", Tcl_PosixError(interp), (char *) NULL); errfile = NULL; } } - - done: + + done: if (errfile != NULL) { - Tcl_AppendResult(interp, + Tcl_AppendResult(interp, ((copyFlag) ? "error copying \"" : "error renaming \""), - Tcl_GetString(source), (char *) NULL); + TclGetString(source), (char *) NULL); if (errfile != source) { - Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target), - (char *) NULL); + Tcl_AppendResult(interp, "\" to \"", TclGetString(target), + (char *) NULL); if (errfile != target) { - Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile), - (char *) NULL); + Tcl_AppendResult(interp, "\": \"", TclGetString(errfile), + (char *) NULL); } } Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), (char *) NULL); } if (errorBuffer != NULL) { - Tcl_DecrRefCount(errorBuffer); + Tcl_DecrRefCount(errorBuffer); } if (actualSource != NULL) { Tcl_DecrRefCount(actualSource); @@ -777,14 +804,13 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * * FileForceOption -- * - * Helps parse command line options for file commands that take - * the "-force" and "--" options. + * Helps parse command line options for file commands that take the + * "-force" and "--" options. * * Results: - * The return value is how many arguments from argv were consumed - * by this function, or -1 if there was an error parsing the - * options. If an error occurred, an error message is left in the - * interp's result. + * The return value is how many arguments from argv were consumed by this + * function, or -1 if there was an error parsing the options. If an error + * occurred, an error message is left in the interp's result. * * Side effects: * None. @@ -798,23 +824,23 @@ FileForceOption(interp, objc, objv, forcePtr) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings. First command line * option, if it exists, begins at 0. */ - int *forcePtr; /* If the "-force" was specified, *forcePtr - * is filled with 1, otherwise with 0. */ + int *forcePtr; /* If the "-force" was specified, *forcePtr is + * filled with 1, otherwise with 0. */ { int force, i; - + force = 0; for (i = 0; i < objc; i++) { - if (Tcl_GetString(objv[i])[0] != '-') { + if (TclGetString(objv[i])[0] != '-') { break; } - if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) { + if (strcmp(TclGetString(objv[i]), "-force") == 0) { force = 1; - } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) { + } else if (strcmp(TclGetString(objv[i]), "--") == 0) { i++; break; } else { - Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]), + Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), "\": should be -force or --", (char *)NULL); return -1; } @@ -829,13 +855,12 @@ FileForceOption(interp, objc, objv, forcePtr) * * Given a path in either tcl format (with / separators), or in the * platform-specific format for the current platform, return all the - * characters in the path after the last directory separator. But, - * if path is the root directory, returns no characters. + * characters in the path after the last directory separator. But, if + * path is the root directory, returns no characters. * * Results: - * Returns the string object that represents the basename. If there - * is an error, an error message is left in interp, and NULL is - * returned. + * Returns the string object that represents the basename. If there is an + * error, an error message is left in interp, and NULL is returned. * * Side effects: * None. @@ -851,12 +876,12 @@ FileBasename(interp, pathPtr) int objc; Tcl_Obj *splitPtr; Tcl_Obj *resultPtr = NULL; - + splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); - + if (objc != 0) { - if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) { + if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { Tcl_DecrRefCount(splitPtr); if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; @@ -873,7 +898,7 @@ FileBasename(interp, pathPtr) if (objc > 0) { Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); if ((objc == 1) && - (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { + (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { resultPtr = NULL; } } @@ -891,33 +916,31 @@ FileBasename(interp, pathPtr) * * TclFileAttrsCmd -- * - * Sets or gets the platform-specific attributes of a file. The - * objc-objv points to the file name with the rest of the command - * line following. This routine uses platform-specific tables of - * option strings and callbacks. The callback to get the - * attributes take three parameters: - * Tcl_Interp *interp; The interp to report errors with. - * Since this is an object-based API, - * the object form of the result should - * be used. + * Sets or gets the platform-specific attributes of a file. The objc-objv + * points to the file name with the rest of the command line following. + * This routine uses platform-specific tables of option strings and + * callbacks. The callback to get the attributes take three parameters: + * Tcl_Interp *interp; The interp to report errors with. Since + * this is an object-based API, the object + * form of the result should be used. * CONST char *fileName; This is extracted using * Tcl_TranslateFileName. - * TclObj **attrObjPtrPtr; A new object to hold the attribute - * is allocated and put here. + * TclObj **attrObjPtrPtr; A new object to hold the attribute is + * allocated and put here. * The first two parameters of the callback used to write out the * attributes are the same. The third parameter is: - * CONST *attrObjPtr; A pointer to the object that has - * the new attribute. - * They both return standard TCL errors; if the routine to get - * an attribute fails, no object is allocated and *attrObjPtrPtr - * is unchanged. + * CONST *attrObjPtr; A pointer to the object that has the new + * attribute. + * They both return standard TCL errors; if the routine to get an + * attribute fails, no object is allocated and *attrObjPtrPtr is + * unchanged. * * Results: - * Standard TCL error. + * Standard TCL error. * * Side effects: - * May set file attributes for the file name. - * + * May set file attributes for the file name. + * *---------------------------------------------------------------------- */ @@ -932,7 +955,7 @@ TclFileAttrsCmd(interp, objc, objv) Tcl_Obj* objStrings = NULL; int numObjStrings = -1; Tcl_Obj *filePtr; - + if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?option? ?value? ?option value ...?"); @@ -943,39 +966,49 @@ TclFileAttrsCmd(interp, objc, objv) if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } - + objc -= 3; objv += 3; result = TCL_ERROR; Tcl_SetErrno(0); + attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); if (attributeStrings == NULL) { int index; Tcl_Obj *objPtr; + if (objStrings == NULL) { if (Tcl_GetErrno() != 0) { - /* - * There was an error, probably that the filePtr is - * not accepted by any filesystem + /* + * There was an error, probably that the filePtr is not + * accepted by any filesystem */ Tcl_AppendResult(interp, "could not read \"", - Tcl_GetString(filePtr), "\": ", Tcl_PosixError(interp), + TclGetString(filePtr), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } goto end; } - /* We own the object now */ + + /* + * We own the object now. + */ + Tcl_IncrRefCount(objStrings); - /* Use objStrings as a list object */ + + /* + * Use objStrings as a list object. + */ + if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { goto end; } attributeStrings = (CONST char **) - ckalloc ((1+numObjStrings) * sizeof(char*)); + ckalloc((1+numObjStrings) * sizeof(char*)); for (index = 0; index < numObjStrings; index++) { Tcl_ListObjIndex(interp, objStrings, index, &objPtr); - attributeStrings[index] = Tcl_GetString(objPtr); + attributeStrings[index] = TclGetString(objPtr); } attributeStrings[index] = NULL; } @@ -986,28 +1019,39 @@ TclFileAttrsCmd(interp, objc, objv) int index, res = TCL_OK, nbAtts = 0; Tcl_Obj *listPtr; - + listPtr = Tcl_NewListObj(0, NULL); for (index = 0; attributeStrings[index] != NULL; index++) { Tcl_Obj *objPtrAttr; - + if (res != TCL_OK) { - /* Clear the error from the last iteration */ - Tcl_ResetResult(interp); + /* + * Clear the error from the last iteration. + */ + + Tcl_ResetResult(interp); } + res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr); if (res == TCL_OK) { - Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1); - Tcl_ListObjAppendElement(interp, listPtr, objPtr); - Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr); - nbAtts++; + Tcl_Obj *objPtr = + Tcl_NewStringObj(attributeStrings[index], -1); + + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr); + nbAtts++; } } + if (index > 0 && nbAtts == 0) { - /* Error: no valid attributes found */ + /* + * Error: no valid attributes found. + */ + Tcl_DecrRefCount(listPtr); goto end; } + Tcl_SetObjResult(interp, listPtr); } else if (objc == 1) { /* @@ -1018,9 +1062,9 @@ TclFileAttrsCmd(interp, objc, objv) Tcl_Obj *objPtr = NULL; if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", - Tcl_GetString(objv[0]), "\", there are no file attributes" - " in this filesystem.", (char *) NULL); + Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), + "\", there are no file attributes in this filesystem.", + (char *) NULL); goto end; } @@ -1039,11 +1083,11 @@ TclFileAttrsCmd(interp, objc, objv) */ int i, index; - + if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", - Tcl_GetString(objv[0]), "\", there are no file attributes" - " in this filesystem.", (char *) NULL); + Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), + "\", there are no file attributes in this filesystem.", + (char *) NULL); goto end; } @@ -1054,8 +1098,7 @@ TclFileAttrsCmd(interp, objc, objv) } if (i + 1 == objc) { Tcl_AppendResult(interp, "value for \"", - Tcl_GetString(objv[i]), "\" missing", - (char *) NULL); + TclGetString(objv[i]), "\" missing", (char *) NULL); goto end; } if (Tcl_FSFileAttrsSet(interp, index, filePtr, @@ -1066,17 +1109,29 @@ TclFileAttrsCmd(interp, objc, objv) } result = TCL_OK; - end: + end: if (numObjStrings != -1) { - /* Free up the array we allocated */ + /* + * Free up the array we allocated. + */ + ckfree((char*)attributeStrings); - /* - * We don't need this object that was passed to us - * any more. + + /* + * We don't need this object that was passed to us any more. */ + if (objStrings != NULL) { Tcl_DecrRefCount(objStrings); } } return result; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclGet.c b/generic/tclGet.c index be3d942..b28b3f92 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -1,17 +1,17 @@ -/* +/* * tclGet.c -- * - * This file contains procedures to convert strings into - * other forms, like integers or floating-point numbers or - * booleans, doing syntax checking along the way. + * This file contains functions to convert strings into other forms, like + * integers or floating-point numbers or booleans, doing syntax checking + * along the way. * * Copyright (c) 1990-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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGet.c,v 1.15 2005/05/10 18:34:38 kennykb Exp $ + * RCS: @(#) $Id: tclGet.c,v 1.16 2005/07/24 22:56:43 dkf Exp $ */ #include "tclInt.h" @@ -25,10 +25,10 @@ * Given a string, produce the corresponding integer value. * * Results: - * The return value is normally TCL_OK; in this case *intPtr - * will be set to the integer value equivalent to src. If - * src is improperly formed then TCL_ERROR is returned and - * an error message will be left in the interp's result. + * The return value is normally TCL_OK; in this case *intPtr will be set + * to the integer value equivalent to src. If src is improperly formed + * then TCL_ERROR is returned and an error message will be left in the + * interp's result. * * Side effects: * None. @@ -45,7 +45,7 @@ Tcl_GetInt(interp, src, intPtr) { Tcl_Obj obj; int code; - + obj.refCount = 1; obj.bytes = (char *) src; obj.length = strlen(src); @@ -63,16 +63,15 @@ Tcl_GetInt(interp, src, intPtr) * * TclGetLong -- * - * Given a string, produce the corresponding long integer value. - * This routine is a version of Tcl_GetInt but returns a "long" - * instead of an "int". + * Given a string, produce the corresponding long integer value. This + * routine is a version of Tcl_GetInt but returns a "long" instead of an + * "int" (a difference that matters on 64-bit architectures). * * Results: - * The return value is normally TCL_OK; in this case *longPtr - * will be set to the long integer value equivalent to src. If - * src is improperly formed then TCL_ERROR is returned and - * an error message will be left in the interp's result if interp - * is non-NULL. + * The return value is normally TCL_OK; in this case *longPtr will be set + * to the long integer value equivalent to src. If src is improperly + * formed then TCL_ERROR is returned and an error message will be left in + * the interp's result if interp is non-NULL. * * Side effects: * None. @@ -82,11 +81,10 @@ Tcl_GetInt(interp, src, intPtr) int TclGetLong(interp, src, longPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting - * if not NULL. */ - CONST char *src; /* String containing a (possibly signed) - * long integer in a form acceptable to - * strtoul. */ + Tcl_Interp *interp; /* Interpreter used for error reporting if not + * NULL. */ + CONST char *src; /* String containing a (possibly signed) long + * integer in a form acceptable to strtoul. */ long *longPtr; /* Place to store converted long result. */ { Tcl_Obj obj; @@ -113,10 +111,10 @@ TclGetLong(interp, src, longPtr) * floating-point value. * * Results: - * The return value is normally TCL_OK; in this case *doublePtr - * will be set to the double-precision value equivalent to src. - * If src is improperly formed then TCL_ERROR is returned and - * an error message will be left in the interp's result. + * The return value is normally TCL_OK; in this case *doublePtr will be + * set to the double-precision value equivalent to src. If src is + * improperly formed then TCL_ERROR is returned and an error message will + * be left in the interp's result. * * Side effects: * None. @@ -151,14 +149,14 @@ Tcl_GetDouble(interp, src, doublePtr) * * Tcl_GetBoolean -- * - * Given a string, return a 0/1 boolean value corresponding - * to the string. + * Given a string, return a 0/1 boolean value corresponding to the + * string. * * Results: - * The return value is normally TCL_OK; in this case *boolPtr - * will be set to the 0/1 value equivalent to src. If - * src is improperly formed then TCL_ERROR is returned and - * an error message will be left in the interp's result. + * The return value is normally TCL_OK; in this case *boolPtr will be set + * to the 0/1 value equivalent to src. If src is improperly formed then + * TCL_ERROR is returned and an error message will be left in the + * interp's result. * * Side effects: * None. @@ -172,8 +170,8 @@ Tcl_GetBoolean(interp, src, boolPtr) CONST char *src; /* String containing a boolean number * specified either as 1/0 or true/false or * yes/no. */ - int *boolPtr; /* Place to store converted result, which - * will be 0 or 1. */ + int *boolPtr; /* Place to store converted result, which will + * be 0 or 1. */ { Tcl_Obj obj; int code; @@ -192,3 +190,11 @@ Tcl_GetBoolean(interp, src, boolPtr) } return code; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index cea5725..8281bc4 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -1,71 +1,73 @@ -/* +/* * tclPreserve.c -- * - * This file contains a collection of procedures that are used - * to make sure that widget records and other data structures - * aren't reallocated when there are nested procedures that - * depend on their existence. + * This file contains a collection of functions that are used to make + * sure that widget records and other data structures aren't reallocated + * when there are nested functions that depend on their existence. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPreserve.c,v 1.6 2005/06/24 20:07:22 kennykb Exp $ + * RCS: @(#) $Id: tclPreserve.c,v 1.7 2005/07/24 22:56:43 dkf Exp $ */ #include "tclInt.h" /* - * The following data structure is used to keep track of all the - * Tcl_Preserve calls that are still in effect. It grows as needed - * to accommodate any number of calls in effect. + * The following data structure is used to keep track of all the Tcl_Preserve + * calls that are still in effect. It grows as needed to accommodate any + * number of calls in effect. */ typedef struct { ClientData clientData; /* Address of preserved block. */ - int refCount; /* Number of Tcl_Preserve calls in effect - * for block. */ + int refCount; /* Number of Tcl_Preserve calls in effect for + * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was * called while a Tcl_Preserve call was in - * effect, so the structure must be freed - * when refCount becomes zero. */ - Tcl_FreeProc *freeProc; /* Procedure to call to free. */ + * effect, so the structure must be freed when + * refCount becomes zero. */ + Tcl_FreeProc *freeProc; /* Function to call to free. */ } Reference; +/* + * Global data structures used to hold the list of preserved data references. + * These variables are protected by "preserveMutex". + */ + static Reference *refArray; /* First in array of references. */ -static int spaceAvl = 0; /* Total number of structures available - * at *firstRefPtr. */ -static int inUse = 0; /* Count of structures currently in use - * in refArray. */ -#define INITIAL_SIZE 2 +static int spaceAvl = 0; /* Total number of structures available at + * *firstRefPtr. */ +static int inUse = 0; /* Count of structures currently in use in + * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ +#define INITIAL_SIZE 2 /* Initial number of reference slots to make */ + /* - * The following data structure is used to keep track of whether an - * arbitrary block of memory has been deleted. This is used by the - * TclHandle code to avoid the more time-expensive algorithm of - * Tcl_Preserve(). This mechanism is mainly used when we have lots of - * references to a few big, expensive objects that we don't want to live - * any longer than necessary. + * The following data structure is used to keep track of whether an arbitrary + * block of memory has been deleted. This is used by the TclHandle code to + * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism + * is mainly used when we have lots of references to a few big, expensive + * objects that we don't want to live any longer than necessary. */ typedef struct HandleStruct { - VOID *ptr; /* Pointer to the memory block being - * tracked. This field will become NULL when - * the memory block is deleted. This field - * must be the first in the structure. */ + VOID *ptr; /* Pointer to the memory block being tracked. + * This field will become NULL when the memory + * block is deleted. This field must be the + * first in the structure. */ #ifdef TCL_MEM_DEBUG - VOID *ptr2; /* Backup copy of the abpve pointer used to + VOID *ptr2; /* Backup copy of the above pointer used to * ensure that the contents of the handle are * not changed by anyone else. */ #endif int refCount; /* Number of TclHandlePreserve() calls in * effect on this handle. */ } HandleStruct; - - /* *---------------------------------------------------------------------- @@ -102,16 +104,16 @@ TclFinalizePreserve() * * Tcl_Preserve -- * - * This procedure is used by a procedure to declare its interest - * in a particular block of memory, so that the block will not be - * reallocated until a matching call to Tcl_Release has been made. + * This function is used by a function to declare its interest in a + * particular block of memory, so that the block will not be reallocated + * until a matching call to Tcl_Release has been made. * * Results: * None. * * Side effects: - * Information is retained so that the block of memory will - * not be freed until at least the matching call to Tcl_Release. + * Information is retained so that the block of memory will not be freed + * until at least the matching call to Tcl_Release. * *---------------------------------------------------------------------- */ @@ -124,12 +126,12 @@ Tcl_Preserve(clientData) int i; /* - * See if there is already a reference for this pointer. If so, - * just increment its reference count. + * See if there is already a reference for this pointer. If so, just + * increment its reference count. */ Tcl_MutexLock(&preserveMutex); - for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) { if (refPtr->clientData == clientData) { refPtr->refCount++; Tcl_MutexUnlock(&preserveMutex); @@ -138,8 +140,8 @@ Tcl_Preserve(clientData) } /* - * Make a reference array if it doesn't already exist, or make it - * bigger if it is full. + * Make a reference array if it doesn't already exist, or make it bigger + * if it is full. */ if (inUse == spaceAvl) { @@ -178,17 +180,16 @@ Tcl_Preserve(clientData) * * Tcl_Release -- * - * This procedure is called to cancel a previous call to - * Tcl_Preserve, thereby allowing a block of memory to be - * freed (if no one else cares about it). + * This function is called to cancel a previous call to Tcl_Preserve, + * thereby allowing a block of memory to be freed (if no one else cares + * about it). * * Results: * None. * * Side effects: - * If Tcl_EventuallyFree has been called for clientData, and if - * no other call to Tcl_Preserve is still in effect, the block of - * memory is freed. + * If Tcl_EventuallyFree has been called for clientData, and if no other + * call to Tcl_Preserve is still in effect, the block of memory is freed. * *---------------------------------------------------------------------- */ @@ -198,48 +199,57 @@ Tcl_Release(clientData) ClientData clientData; /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - int mustFree; - Tcl_FreeProc *freeProc; int i; Tcl_MutexLock(&preserveMutex); - for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) { + int mustFree; + Tcl_FreeProc *freeProc; + if (refPtr->clientData != clientData) { continue; } - refPtr->refCount--; - if (refPtr->refCount == 0) { - - /* - * Must remove information from the slot before calling freeProc - * to avoid reentrancy problems if the freeProc calls Tcl_Preserve - * on the same clientData. Copy down the last reference in the - * array to overwrite the current slot. - */ - - freeProc = refPtr->freeProc; - mustFree = refPtr->mustFree; - inUse--; - if (i < inUse) { - refArray[i] = refArray[inUse]; - } - if (mustFree) { - if (freeProc == TCL_DYNAMIC) { - ckfree((char *) clientData); - } else { - Tcl_MutexUnlock(&preserveMutex); - (*freeProc)((char *) clientData); - return; - } - } + + if (--refPtr->refCount != 0) { + Tcl_MutexUnlock(&preserveMutex); + return; + } + + /* + * Must remove information from the slot before calling freeProc to + * avoid reentrancy problems if the freeProc calls Tcl_Preserve on the + * same clientData. Copy down the last reference in the array to + * overwrite the current slot. + */ + + freeProc = refPtr->freeProc; + mustFree = refPtr->mustFree; + inUse--; + if (i < inUse) { + refArray[i] = refArray[inUse]; } + + /* + * Now committed to disposing the data. But first, we've patched up + * all the global data structures so we should release the mutex now. + * Only then should we dabble around with potentially-slow memory + * managers... + */ + Tcl_MutexUnlock(&preserveMutex); + if (mustFree) { + if (freeProc == TCL_DYNAMIC) { + ckfree((char *) clientData); + } else { + (*freeProc)((char *) clientData); + } + } return; } Tcl_MutexUnlock(&preserveMutex); /* - * Reference not found. This is a bug in the caller. + * Reference not found. This is a bug in the caller. */ Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", clientData); @@ -250,10 +260,9 @@ Tcl_Release(clientData) * * Tcl_EventuallyFree -- * - * Free up a block of memory, unless a call to Tcl_Preserve is in - * effect for that block. In this case, defer the free until all - * calls to Tcl_Preserve have been undone by matching calls to - * Tcl_Release. + * Free up a block of memory, unless a call to Tcl_Preserve is in effect + * for that block. In this case, defer the free until all calls to + * Tcl_Preserve have been undone by matching calls to Tcl_Release. * * Results: * None. @@ -267,14 +276,14 @@ Tcl_Release(clientData) void Tcl_EventuallyFree(clientData, freeProc) ClientData clientData; /* Pointer to malloc'ed block of memory. */ - Tcl_FreeProc *freeProc; /* Procedure to actually do free. */ + Tcl_FreeProc *freeProc; /* Function to actually do free. */ { Reference *refPtr; int i; /* - * See if there is a reference for this pointer. If so, set its - * "mustFree" flag (the flag had better not be set already!). + * See if there is a reference for this pointer. If so, set its "mustFree" + * flag (the flag had better not be set already!). */ Tcl_MutexLock(&preserveMutex); @@ -283,7 +292,8 @@ Tcl_EventuallyFree(clientData, freeProc) continue; } if (refPtr->mustFree) { - Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData); + Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x\n", + clientData); } refPtr->mustFree = 1; refPtr->freeProc = freeProc; @@ -308,31 +318,29 @@ Tcl_EventuallyFree(clientData, freeProc) * * TclHandleCreate -- * - * Allocate a handle that contains enough information to determine - * if an arbitrary malloc'd block has been deleted. This is - * used to avoid the more time-expensive algorithm of Tcl_Preserve(). + * Allocate a handle that contains enough information to determine if an + * arbitrary malloc'd block has been deleted. This is used to avoid the + * more time-expensive algorithm of Tcl_Preserve(). * * Results: * The return value is a TclHandle that refers to the given malloc'd - * block. Doubly dereferencing the returned handle will give - * back the pointer to the block, or will give NULL if the block has - * been deleted. + * block. Doubly dereferencing the returned handle will give back the + * pointer to the block, or will give NULL if the block has been deleted. * * Side effects: - * The caller must keep track of this handle (generally by storing - * it in a field in the malloc'd block) and call TclHandleFree() - * on this handle when the block is deleted. Everything else that - * wishes to keep track of whether the malloc'd block has been deleted - * should use calls to TclHandlePreserve() and TclHandleRelease() - * on the associated handle. + * The caller must keep track of this handle (generally by storing it in + * a field in the malloc'd block) and call TclHandleFree() on this handle + * when the block is deleted. Everything else that wishes to keep track + * of whether the malloc'd block has been deleted should use calls to + * TclHandlePreserve() and TclHandleRelease() on the associated handle. * *--------------------------------------------------------------------------- */ TclHandle TclHandleCreate(ptr) - VOID *ptr; /* Pointer to an arbitrary block of memory - * to be tracked for deletion. Must not be + VOID *ptr; /* Pointer to an arbitrary block of memory to + * be tracked for deletion. Must not be * NULL. */ { HandleStruct *handlePtr; @@ -351,11 +359,10 @@ TclHandleCreate(ptr) * * TclHandleFree -- * - * Called when the arbitrary malloc'd block associated with the - * handle is being deleted. Modifies the handle so that doubly - * dereferencing it will give NULL. This informs any user of the - * handle that the block of memory formerly referenced by the - * handle has been freed. + * Called when the arbitrary malloc'd block associated with the handle is + * being deleted. Modifies the handle so that doubly dereferencing it + * will give NULL. This informs any user of the handle that the block of + * memory formerly referenced by the handle has been freed. * * Results: * None. @@ -368,10 +375,10 @@ TclHandleCreate(ptr) void TclHandleFree(handle) - TclHandle handle; /* Previously created handle associated - * with a malloc'd block that is being - * deleted. The handle is modified so that - * doubly dereferencing it will give NULL. */ + TclHandle handle; /* Previously created handle associated with a + * malloc'd block that is being deleted. The + * handle is modified so that doubly + * dereferencing it will give NULL. */ { HandleStruct *handlePtr; @@ -396,25 +403,25 @@ TclHandleFree(handle) * * TclHandlePreserve -- * - * Declare an interest in the arbitrary malloc'd block associated - * with the handle. + * Declare an interest in the arbitrary malloc'd block associated with + * the handle. * * Results: * The return value is the handle argument, with its ref count * incremented. * * Side effects: - * For each call to TclHandlePreserve(), there should be a matching - * call to TclHandleRelease() when the caller is no longer interested - * in the malloc'd block associated with the handle. + * For each call to TclHandlePreserve(), there should be a matching call + * to TclHandleRelease() when the caller is no longer interested in the + * malloc'd block associated with the handle. * *--------------------------------------------------------------------------- */ TclHandle TclHandlePreserve(handle) - TclHandle handle; /* Declare an interest in the block of - * memory referenced by this handle. */ + TclHandle handle; /* Declare an interest in the block of memory + * referenced by this handle. */ { HandleStruct *handlePtr; @@ -423,8 +430,7 @@ TclHandlePreserve(handle) if (handlePtr->refCount == 0x61616161) { Tcl_Panic("using previously disposed TclHandle %x", handlePtr); } - if ((handlePtr->ptr != NULL) - && (handlePtr->ptr != handlePtr->ptr2)) { + if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", handlePtr, handlePtr->ptr2, handlePtr->ptr); } @@ -439,24 +445,24 @@ TclHandlePreserve(handle) * * TclHandleRelease -- * - * This procedure is called to release an interest in the malloc'd - * block associated with the handle. + * This function is called to release an interest in the malloc'd block + * associated with the handle. * * Results: * None. * * Side effects: - * The ref count of the handle is decremented. If the malloc'd block - * has been freed and if no one is using the handle any more, the - * handle will be reclaimed. + * The ref count of the handle is decremented. If the malloc'd block has + * been freed and if no one is using the handle any more, the handle will + * be reclaimed. * *--------------------------------------------------------------------------- */ - + void TclHandleRelease(handle) - TclHandle handle; /* Unregister interest in the block of - * memory referenced by this handle. */ + TclHandle handle; /* Unregister interest in the block of memory + * referenced by this handle. */ { HandleStruct *handlePtr; @@ -465,8 +471,7 @@ TclHandleRelease(handle) if (handlePtr->refCount == 0x61616161) { Tcl_Panic("using previously disposed TclHandle %x", handlePtr); } - if ((handlePtr->ptr != NULL) - && (handlePtr->ptr != handlePtr->ptr2)) { + if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", handlePtr, handlePtr->ptr2, handlePtr->ptr); } @@ -476,4 +481,11 @@ TclHandleRelease(handle) ckfree((char *) handlePtr); } } - + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclResult.c b/generic/tclResult.c index 1266191..a575a40 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1,64 +1,65 @@ -/* +/* * tclResult.c -- * * This file contains code to manage the interpreter result. * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclResult.c,v 1.28 2005/06/02 03:11:38 dgp Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.29 2005/07/24 22:56:43 dkf Exp $ */ #include "tclInt.h" -/* Indices of the standard return options dictionary keys */ +/* + * Indices of the standard return options dictionary keys. + */ + enum returnKeys { KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE, KEY_LEVEL, KEY_OPTIONS, KEY_LAST }; /* - * Function prototypes for local procedures in this file: + * Function prototypes for local functions in this file: */ -static Tcl_Obj ** GetKeys(); +static Tcl_Obj ** GetKeys _ANSI_ARGS_((void)); static void ReleaseKeys _ANSI_ARGS_((ClientData clientData)); -static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); +static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, int newSpace)); /* - * This structure is used to take a snapshot of the interpreter - * state in Tcl_SaveInterpState. You can snapshot the state, - * execute a command, and then back up to the result or the - * error that was previously in progress. + * This structure is used to take a snapshot of the interpreter state in + * Tcl_SaveInterpState. You can snapshot the state, execute a command, and + * then back up to the result or the error that was previously in progress. */ + typedef struct InterpState { int status; /* return code status */ - int flags; /* Each remaining field saves */ - int returnLevel; /* the corresponding field of */ - int returnCode; /* the Interp struct. These */ - Tcl_Obj *errorInfo; /* fields take together are the */ - Tcl_Obj *errorCode; /* "state" of the interp. */ + int flags; /* Each remaining field saves the */ + int returnLevel; /* corresponding field of the Interp */ + int returnCode; /* struct. These fields taken together are */ + Tcl_Obj *errorInfo; /* the "state" of the interp. */ + Tcl_Obj *errorCode; Tcl_Obj *returnOpts; Tcl_Obj *objResult; } InterpState; - /* *---------------------------------------------------------------------- * * Tcl_SaveInterpState -- * - * Fills a token with a snapshot of the current state of the - * interpreter. The snapshot can be restored at any point by - * TclRestoreInterpState. + * Fills a token with a snapshot of the current state of the interpreter. + * The snapshot can be restored at any point by TclRestoreInterpState. * - * The token returned must be eventally passed to one of the - * routines TclRestoreInterpState or TclDiscardInterpState, - * or there will be a memory leak. + * The token returned must be eventally passed to one of the routines + * TclRestoreInterpState or TclDiscardInterpState, or there will be a + * memory leak. * * Results: * Returns a token representing the interp state. @@ -71,8 +72,8 @@ typedef struct InterpState { Tcl_InterpState Tcl_SaveInterpState(interp, status) - Tcl_Interp* interp; /* Interpreter's state to be saved */ - int status; /* status code for current operation */ + Tcl_Interp* interp; /* Interpreter's state to be saved */ + int status; /* status code for current operation */ { Interp *iPtr = (Interp *)interp; InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState)); @@ -103,9 +104,9 @@ Tcl_SaveInterpState(interp, status) * * Tcl_RestoreInterpState -- * - * Accepts an interp and a token previously returned by - * Tcl_SaveInterpState. Restore the state of the interp - * to what it was at the time of the Tcl_SaveInterpState call. + * Accepts an interp and a token previously returned by + * Tcl_SaveInterpState. Restore the state of the interp to what it was at + * the time of the Tcl_SaveInterpState call. * * Results: * Returns the status value originally passed in to Tcl_SaveInterpState. @@ -161,8 +162,8 @@ Tcl_RestoreInterpState(interp, state) * * Tcl_DiscardInterpState -- * - * Accepts a token previously returned by Tcl_SaveInterpState. - * Frees the memory it uses. + * Accepts a token previously returned by Tcl_SaveInterpState. Frees the + * memory it uses. * * Results: * None. @@ -180,13 +181,13 @@ Tcl_DiscardInterpState(state) InterpState *statePtr = (InterpState *)state; if (statePtr->errorInfo) { - Tcl_DecrRefCount(statePtr->errorInfo); + Tcl_DecrRefCount(statePtr->errorInfo); } if (statePtr->errorCode) { - Tcl_DecrRefCount(statePtr->errorCode); + Tcl_DecrRefCount(statePtr->errorCode); } if (statePtr->returnOpts) { - Tcl_DecrRefCount(statePtr->returnOpts); + Tcl_DecrRefCount(statePtr->returnOpts); } Tcl_DecrRefCount(statePtr->objResult); ckfree((char*) statePtr); @@ -197,15 +198,13 @@ Tcl_DiscardInterpState(state) * * Tcl_SaveResult -- * - * Takes a snapshot of the current result state of the interpreter. - * The snapshot can be restored at any point by - * Tcl_RestoreResult. Note that this routine does not - * preserve the errorCode, errorInfo, or flags fields so it - * should not be used if an error is in progress. + * Takes a snapshot of the current result state of the interpreter. The + * snapshot can be restored at any point by Tcl_RestoreResult. Note that + * this routine does not preserve the errorCode, errorInfo, or flags + * fields so it should not be used if an error is in progress. * - * Once a snapshot is saved, it must be restored by calling - * Tcl_RestoreResult, or discarded by calling - * Tcl_DiscardResult. + * Once a snapshot is saved, it must be restored by calling + * Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult. * * Results: * None. @@ -224,17 +223,17 @@ Tcl_SaveResult(interp, statePtr) Interp *iPtr = (Interp *) interp; /* - * Move the result object into the save state. Note that we don't need - * to change its refcount because we're moving it, not adding a new - * reference. Put an empty object into the interpreter. + * Move the result object into the save state. Note that we don't need to + * change its refcount because we're moving it, not adding a new + * reference. Put an empty object into the interpreter. */ statePtr->objResultPtr = iPtr->objResultPtr; - iPtr->objResultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(iPtr->objResultPtr); + iPtr->objResultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(iPtr->objResultPtr); /* - * Save the string result. + * Save the string result. */ statePtr->freeProc = iPtr->freeProc; @@ -277,15 +276,15 @@ Tcl_SaveResult(interp, statePtr) * * Tcl_RestoreResult -- * - * Restores the state of the interpreter to a snapshot taken - * by Tcl_SaveResult. After this call, the token for - * the interpreter state is no longer valid. + * Restores the state of the interpreter to a snapshot taken by + * Tcl_SaveResult. After this call, the token for the interpreter state + * is no longer valid. * * Results: - * None. + * None. * * Side effects: - * Restores the interpreter result. + * Restores the interpreter result. * *---------------------------------------------------------------------- */ @@ -345,16 +344,15 @@ Tcl_RestoreResult(interp, statePtr) * * Tcl_DiscardResult -- * - * Frees the memory associated with an interpreter snapshot - * taken by Tcl_SaveResult. If the snapshot is not - * restored, this procedure must be called to discard it, - * or the memory will be lost. + * Frees the memory associated with an interpreter snapshot taken by + * Tcl_SaveResult. If the snapshot is not restored, this function must be + * called to discard it, or the memory will be lost. * * Results: - * None. + * None. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -387,8 +385,8 @@ Tcl_DiscardResult(statePtr) * None. * * Side effects: - * interp->result is left pointing either to "result" - * or to a copy of it. Also, the object result is reset. + * interp->result is left pointing either to "result" or to a copy of it. + * Also, the object result is reset. * *---------------------------------------------------------------------- */ @@ -397,11 +395,11 @@ void Tcl_SetResult(interp, result, freeProc) Tcl_Interp *interp; /* Interpreter with which to associate the * return value. */ - register char *result; /* Value to be returned. If NULL, the - * result is set to an empty string. */ + register char *result; /* Value to be returned. If NULL, the result + * is set to an empty string. */ Tcl_FreeProc *freeProc; /* Gives information about the string: - * TCL_STATIC, TCL_VOLATILE, or the address - * of a Tcl_FreeProc such as free. */ + * TCL_STATIC, TCL_VOLATILE, or the address of + * a Tcl_FreeProc such as free. */ { Interp *iPtr = (Interp *) interp; int length; @@ -428,9 +426,9 @@ Tcl_SetResult(interp, result, freeProc) } /* - * If the old result was dynamically-allocated, free it up. Do it - * here, rather than at the beginning, in case the new result value - * was part of the old result value. + * If the old result was dynamically-allocated, free it up. Do it here, + * rather than at the beginning, in case the new result value was part of + * the old result value. */ if (oldFreeProc != 0) { @@ -467,16 +465,16 @@ Tcl_SetResult(interp, result, freeProc) CONST char * Tcl_GetStringResult(interp) - register Tcl_Interp *interp; /* Interpreter whose result to return. */ + register Tcl_Interp *interp;/* Interpreter whose result to return. */ { /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. + * If the string result is empty, move the object result to the string + * result, then reset the object result. */ - + if (*(interp->result) == 0) { Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); + TCL_VOLATILE); } return interp->result; } @@ -492,11 +490,10 @@ Tcl_GetStringResult(interp) * None. * * Side effects: - * interp->objResultPtr is left pointing to the object referenced - * by objPtr. The object's reference count is incremented since - * there is now a new reference to it. The reference count for any - * old objResultPtr value is decremented. Also, the string result - * is reset. + * interp->objResultPtr is left pointing to the object referenced by + * objPtr. The object's reference count is incremented since there is now + * a new reference to it. The reference count for any old objResultPtr + * value is decremented. Also, the string result is reset. * *---------------------------------------------------------------------- */ @@ -505,9 +502,8 @@ void Tcl_SetObjResult(interp, objPtr) Tcl_Interp *interp; /* Interpreter with which to associate the * return object value. */ - register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the - * obj result is made an empty string - * object. */ + register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the obj + * result is made an empty string object. */ { register Interp *iPtr = (Interp *) interp; register Tcl_Obj *oldObjResult = iPtr->objResultPtr; @@ -516,10 +512,10 @@ Tcl_SetObjResult(interp, objPtr) Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ /* - * We wait until the end to release the old object result, in case - * we are setting the result to itself. + * We wait until the end to release the old object result, in case we are + * setting the result to itself. */ - + TclDecrRefCount(oldObjResult); /* @@ -544,17 +540,17 @@ Tcl_SetObjResult(interp, objPtr) * Tcl_GetObjResult -- * * Returns an interpreter's result value as a Tcl object. The object's - * reference count is not modified; the caller must do that if it - * needs to hold on to a long-term reference to it. + * reference count is not modified; the caller must do that if it needs + * to hold on to a long-term reference to it. * * Results: * The interpreter's result as an object. * * Side effects: - * If the interpreter has a non-empty string result, the result object - * is either empty or stale because some procedure set interp->result - * directly. If so, the string result is moved to the result object - * then the string result is reset. + * If the interpreter has a non-empty string result, the result object is + * either empty or stale because some function set interp->result + * directly. If so, the string result is moved to the result object then + * the string result is reset. * *---------------------------------------------------------------------- */ @@ -568,17 +564,17 @@ Tcl_GetObjResult(interp) int length; /* - * If the string result is non-empty, move the string result to the - * object result, then reset the string result. + * If the string result is non-empty, move the string result to the object + * result, then reset the string result. */ - + if (*(iPtr->result) != 0) { ResetObjResult(iPtr); - + objResultPtr = iPtr->objResultPtr; length = strlen(iPtr->result); TclInitStringRep(objResultPtr, iPtr->result, length); - + if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -598,20 +594,17 @@ Tcl_GetObjResult(interp) * * Tcl_AppendResultVA -- * - * Append a variable number of strings onto the interpreter's - * result. + * Append a variable number of strings onto the interpreter's result. * * Results: * None. * * Side effects: - * The result of the interpreter given by the first argument is - * extended by the strings in the va_list (up to a terminating - * NULL argument). + * The result of the interpreter given by the first argument is extended + * by the strings in the va_list (up to a terminating NULL argument). * - * If the string result is non-empty, the object result forced to - * be a duplicate of it first. There will be a string result - * afterwards. + * If the string result is non-empty, the object result forced to be a + * duplicate of it first. There will be a string result afterwards. * *---------------------------------------------------------------------- */ @@ -629,19 +622,19 @@ Tcl_AppendResultVA(interp, argList) } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); + /* - * Strictly we should call Tcl_GetStringResult(interp) here to - * make sure that interp->result is correct according to the old - * contract, but that makes the performance of much code (e.g. in - * Tk) absolutely awful. So we leave it out; code that really - * wants interp->result can just insert the calls to - * Tcl_GetStringResult() itself. [Patch 1041072 discussion] + * Strictly we should call Tcl_GetStringResult(interp) here to make sure + * that interp->result is correct according to the old contract, but that + * makes the performance of much code (e.g. in Tk) absolutely awful. So we + * leave it out; code that really wants interp->result can just insert the + * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] */ #ifdef USE_DIRECT_INTERP_RESULT_ACCESS /* - * Ensure that the interp->result is legal so old Tcl 7.* code - * still works. There's still embarrasingly much of it about... + * Ensure that the interp->result is legal so old Tcl 7.* code still + * works. There's still embarrasingly much of it about... */ (void) Tcl_GetStringResult(interp); @@ -653,20 +646,18 @@ Tcl_AppendResultVA(interp, argList) * * Tcl_AppendResult -- * - * Append a variable number of strings onto the interpreter's - * result. + * Append a variable number of strings onto the interpreter's result. * * Results: * None. * * Side effects: - * The result of the interpreter given by the first argument is - * extended by the strings given by the second and following - * arguments (up to a terminating NULL argument). + * The result of the interpreter given by the first argument is extended + * by the strings given by the second and following arguments (up to a + * terminating NULL argument). * - * If the string result is non-empty, the object result forced to - * be a duplicate of it first. There will be a string result - * afterwards. + * If the string result is non-empty, the object result forced to be a + * duplicate of it first. There will be a string result afterwards. * *---------------------------------------------------------------------- */ @@ -694,10 +685,10 @@ Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) * None. * * Side effects: - * The result in the interpreter given by the first argument is - * extended with a list element converted from string. A separator - * space is added before the converted list element unless the current - * result is empty, contains the single character "{", or ends in " {". + * The result in the interpreter given by the first argument is extended + * with a list element converted from string. A separator space is added + * before the converted list element unless the current result is empty, + * contains the single character "{", or ends in " {". * * If the string result is empty, the object result is moved to the * string result, then the object result is reset. @@ -709,8 +700,8 @@ void Tcl_AppendElement(interp, element) Tcl_Interp *interp; /* Interpreter whose result is to be * extended. */ - CONST char *element; /* String to convert to list element and - * add to result. */ + CONST char *element; /* String to convert to list element and add + * to result. */ { Interp *iPtr = (Interp *) interp; char *dst; @@ -718,27 +709,27 @@ Tcl_AppendElement(interp, element) int flags; /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. + * If the string result is empty, move the object result to the string + * result, then reset the object result. */ (void) Tcl_GetStringResult(interp); /* - * See how much space is needed, and grow the append buffer if - * needed to accommodate the list element. + * See how much space is needed, and grow the append buffer if needed to + * accommodate the list element. */ size = Tcl_ScanElement(element, &flags) + 1; if ((iPtr->result != iPtr->appendResult) || (iPtr->appendResult[iPtr->appendUsed] != 0) || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { - SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); } /* - * Convert the string into a list element and copy it to the - * buffer that's forming, with a space separator if needed. + * Convert the string into a list element and copy it to the buffer that's + * forming, with a space separator if needed. */ dst = iPtr->appendResult + iPtr->appendUsed; @@ -746,11 +737,13 @@ Tcl_AppendElement(interp, element) iPtr->appendUsed++; *dst = ' '; dst++; + /* - * If we need a space to separate this element from preceding - * stuff, then this element will not lead a list, and need not - * have it's leading '#' quoted. + * If we need a space to separate this element from preceding stuff, + * then this element will not lead a list, and need not have it's + * leading '#' quoted. */ + flags |= TCL_DONT_QUOTE_HASH; } iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); @@ -761,10 +754,10 @@ Tcl_AppendElement(interp, element) * * SetupAppendBuffer -- * - * This procedure makes sure that there is an append buffer properly - * initialized, if necessary, from the interpreter's result, and - * that it has at least enough room to accommodate newSpace new - * bytes of information. + * This function makes sure that there is an append buffer properly + * initialized, if necessary, from the interpreter's result, and that it + * has at least enough room to accommodate newSpace new bytes of + * information. * * Results: * None. @@ -778,8 +771,8 @@ Tcl_AppendElement(interp, element) static void SetupAppendBuffer(iPtr, newSpace) Interp *iPtr; /* Interpreter whose result is being set up. */ - int newSpace; /* Make sure that at least this many bytes - * of new information may be added. */ + int newSpace; /* Make sure that at least this many bytes of + * new information may be added. */ { int totalSpace; @@ -791,9 +784,9 @@ SetupAppendBuffer(iPtr, newSpace) if (iPtr->result != iPtr->appendResult) { /* - * If an oversized buffer was used recently, then free it up - * so we go back to a smaller buffer. This avoids tying up - * memory forever after a large operation. + * If an oversized buffer was used recently, then free it up so we go + * back to a smaller buffer. This avoids tying up memory forever after + * a large operation. */ if (iPtr->appendAvl > 500) { @@ -805,13 +798,13 @@ SetupAppendBuffer(iPtr, newSpace) } else if (iPtr->result[iPtr->appendUsed] != 0) { /* * Most likely someone has modified a result created by - * Tcl_AppendResult et al. so that it has a different size. - * Just recompute the size. + * Tcl_AppendResult et al. so that it has a different size. Just + * recompute the size. */ iPtr->appendUsed = strlen(iPtr->result); } - + totalSpace = newSpace + iPtr->appendUsed; if (totalSpace >= iPtr->appendAvl) { char *new; @@ -831,7 +824,7 @@ SetupAppendBuffer(iPtr, newSpace) } else if (iPtr->result != iPtr->appendResult) { strcpy(iPtr->appendResult, iPtr->result); } - + Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } @@ -841,9 +834,9 @@ SetupAppendBuffer(iPtr, newSpace) * * Tcl_FreeResult -- * - * This procedure frees up the memory associated with an interpreter's + * This function frees up the memory associated with an interpreter's * string result. It also resets the interpreter's result object. - * Tcl_FreeResult is most commonly used when a procedure is about to + * Tcl_FreeResult is most commonly used when a function is about to * replace one result value with another. * * Results: @@ -851,9 +844,9 @@ SetupAppendBuffer(iPtr, newSpace) * * Side effects: * Frees the memory associated with interp's string result and sets - * interp->freeProc to zero, but does not change interp->result or - * clear error state. Resets interp's result object to an unshared - * empty object. + * interp->freeProc to zero, but does not change interp->result or clear + * error state. Resets interp's result object to an unshared empty + * object. * *---------------------------------------------------------------------- */ @@ -863,7 +856,7 @@ Tcl_FreeResult(interp) register Tcl_Interp *interp; /* Interpreter for which to free result. */ { register Interp *iPtr = (Interp *) interp; - + if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -872,7 +865,7 @@ Tcl_FreeResult(interp) } iPtr->freeProc = 0; } - + ResetObjResult(iPtr); } @@ -881,15 +874,14 @@ Tcl_FreeResult(interp) * * Tcl_ResetResult -- * - * This procedure resets both the interpreter's string and object - * results. + * This function resets both the interpreter's string and object results. * * Results: * None. * * Side effects: - * It resets the result object to an unshared empty object. It - * then restores the interpreter's string result area to its default + * It resets the result object to an unshared empty object. It then + * restores the interpreter's string result area to its default * initialized state, freeing up any memory that may have been * allocated. It also clears any error information for the interpreter. * @@ -941,15 +933,15 @@ Tcl_ResetResult(interp) * * ResetObjResult -- * - * Procedure used to reset an interpreter's Tcl result object. + * Function used to reset an interpreter's Tcl result object. * * Results: * None. * * Side effects: * Resets the interpreter's result object to an unshared empty string - * object with ref count one. It does not clear any error information - * in the interpreter. + * object with ref count one. It does not clear any error information in + * the interpreter. * *---------------------------------------------------------------------- */ @@ -968,7 +960,7 @@ ResetObjResult(iPtr) iPtr->objResultPtr = objResultPtr; } else { if ((objResultPtr->bytes != NULL) - && (objResultPtr->bytes != tclEmptyStringRep)) { + && (objResultPtr->bytes != tclEmptyStringRep)) { ckfree((char *) objResultPtr->bytes); } objResultPtr->bytes = tclEmptyStringRep; @@ -983,30 +975,30 @@ ResetObjResult(iPtr) * * Tcl_SetErrorCodeVA -- * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. + * This function is called to record machine-readable information about + * an error that is about to be returned. * * Results: * None. * * Side effects: * The errorCode field of the interp is modified to hold all of the - * arguments to this procedure, in a list form with each argument - * becoming one element of the list. + * arguments to this function, in a list form with each argument becoming + * one element of the list. * *---------------------------------------------------------------------- */ void -Tcl_SetErrorCodeVA (interp, argList) +Tcl_SetErrorCodeVA(interp, argList) Tcl_Interp *interp; /* Interpreter in which to set errorCode */ va_list argList; /* Variable argument list. */ { Tcl_Obj *errorObj = Tcl_NewObj(); /* - * Scan through the arguments one at a time, appending them to - * the errorCode field as list elements. + * Scan through the arguments one at a time, appending them to the + * errorCode field as list elements. */ while (1) { @@ -1024,19 +1016,20 @@ Tcl_SetErrorCodeVA (interp, argList) * * Tcl_SetErrorCode -- * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. + * This function is called to record machine-readable information about + * an error that is about to be returned. * * Results: * None. * * Side effects: * The errorCode field of the interp is modified to hold all of the - * arguments to this procedure, in a list form with each argument - * becoming one element of the list. + * arguments to this function, in a list form with each argument becoming + * one element of the list. * *---------------------------------------------------------------------- */ + /* VARARGS2 */ void Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) @@ -1045,8 +1038,8 @@ Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) va_list argList; /* - * Scan through the arguments one at a time, appending them to - * the errorCode field as list elements. + * Scan through the arguments one at a time, appending them to the + * errorCode field as list elements. */ interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); @@ -1059,9 +1052,9 @@ Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) * * Tcl_SetObjErrorCode -- * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. The caller should - * build a list object up and pass it to this routine. + * This function is called to record machine-readable information about + * an error that is about to be returned. The caller should build a list + * object up and pass it to this routine. * * Results: * None. @@ -1078,7 +1071,7 @@ Tcl_SetObjErrorCode(interp, errorObjPtr) Tcl_Obj *errorObjPtr; { Interp *iPtr = (Interp *) interp; - + if (iPtr->errorCode) { Tcl_DecrRefCount(iPtr->errorCode); } @@ -1091,18 +1084,18 @@ Tcl_SetObjErrorCode(interp, errorObjPtr) * * GetKeys -- * - * Returns a Tcl_Obj * array of the standard keys used in the - * return options dictionary. + * Returns a Tcl_Obj * array of the standard keys used in the return + * options dictionary. * - * Broadly sharing one copy of these key values helps with both - * memory efficiency and dictionary lookup times. + * Broadly sharing one copy of these key values helps with both memory + * efficiency and dictionary lookup times. * * Results: * A Tcl_Obj * array. * * Side effects: - * First time called in a thread, creates the keys (allocating - * memory) and arranges for their cleanup at thread exit. + * First time called in a thread, creates the keys (allocating memory) + * and arranges for their cleanup at thread exit. * *---------------------------------------------------------------------- */ @@ -1113,19 +1106,29 @@ GetKeys() static Tcl_ThreadDataKey returnKeysKey; Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey, (int) (KEY_LAST * sizeof(Tcl_Obj *))); + if (keys[0] == NULL) { - /* First call in this thread, create the keys... */ + /* + * First call in this thread, create the keys... + */ + int i; - keys[KEY_CODE] = Tcl_NewStringObj("-code", -1); - keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1); - keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1); - keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1); - keys[KEY_LEVEL] = Tcl_NewStringObj("-level", -1); - keys[KEY_OPTIONS] = Tcl_NewStringObj("-options", -1); + + keys[KEY_CODE] = Tcl_NewStringObj("-code", -1); + keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1); + keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1); + keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1); + keys[KEY_LEVEL] = Tcl_NewStringObj("-level", -1); + keys[KEY_OPTIONS] = Tcl_NewStringObj("-options", -1); + for (i = KEY_CODE; i < KEY_LAST; i++) { Tcl_IncrRefCount(keys[i]); } - /* ... and arrange for their clenaup. */ + + /* + * ... and arrange for their clenaup. + */ + Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys); } return keys; @@ -1136,8 +1139,8 @@ GetKeys() * * ReleaseKeys -- * - * Called as a thread exit handler to cleanup return options - * dictionary keys. + * Called as a thread exit handler to cleanup return options dictionary + * keys. * * Results: * None. @@ -1154,6 +1157,7 @@ ReleaseKeys(clientData) { Tcl_Obj **keys = (Tcl_Obj **)clientData; int i; + for (i = KEY_CODE; i < KEY_LAST; i++) { Tcl_DecrRefCount(keys[i]); } @@ -1164,11 +1168,11 @@ ReleaseKeys(clientData) * * TclProcessReturn -- * - * Does the work of the [return] command based on the code, - * level, and returnOpts arguments. Note that the code argument - * must agree with the -code entry in returnOpts and the level - * argument must agree with the -level entry in returnOpts, as - * is the case for values returned from TclMergeReturnOptions. + * Does the work of the [return] command based on the code, level, and + * returnOpts arguments. Note that the code argument must agree with the + * -code entry in returnOpts and the level argument must agree with the + * -level entry in returnOpts, as is the case for values returned from + * TclMergeReturnOptions. * * Results: * Returns the return code the [return] command should return. @@ -1190,7 +1194,10 @@ TclProcessReturn(interp, code, level, returnOpts) Tcl_Obj *valuePtr; Tcl_Obj **keys = GetKeys(); - /* Store the merged return options */ + /* + * Store the merged return options. + */ + if (iPtr->returnOpts != returnOpts) { if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); @@ -1207,6 +1214,7 @@ TclProcessReturn(interp, code, level, returnOpts) Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { int infoLen; + (void) Tcl_GetStringFromObj(valuePtr, &infoLen); if (infoLen) { iPtr->errorInfo = valuePtr; @@ -1242,9 +1250,9 @@ TclProcessReturn(interp, code, level, returnOpts) * Parses, checks, and stores the options to the [return] command. * * Results: - * Returns TCL_ERROR is any of the option values are invalid. - * Otherwise, returns TCL_OK, and writes the returnOpts, code, - * and level values to the pointers provided. + * Returns TCL_ERROR is any of the option values are invalid. Otherwise, + * returns TCL_OK, and writes the returnOpts, code, and level values to + * the pointers provided. * * Side effects: * None. @@ -1257,10 +1265,9 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ - Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a - * (Tcl_Obj *) where the pointer to the - * merged return options dictionary should - * be written */ + Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a (Tcl_Obj + * *) where the pointer to the merged return + * options dictionary should be written */ int *codePtr; /* If not NULL, points to space where the * -code value should be written */ int *levelPtr; /* If not NULL, points to space where the @@ -1285,13 +1292,16 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) Tcl_Obj *keyPtr; Tcl_Obj *dict = objv[1]; - nestedOptions: - if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, - &search, &keyPtr, &valuePtr, &done)) { - /* Value is not a legal dictionary */ + nestedOptions: + if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search, + &keyPtr, &valuePtr, &done)) { + /* + * Value is not a legal dictionary. + */ + Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad ", - compare, " value: expected dictionary but got \"", + Tcl_AppendResult(interp, "bad ", compare, + " value: expected dictionary but got \"", TclGetString(objv[1]), "\"", (char *) NULL); goto error; } @@ -1313,9 +1323,12 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) } } - /* Check for bogus -code value */ + /* + * Check for bogus -code value. + */ + Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); - if ((valuePtr != NULL) + if ((valuePtr != NULL) && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) { static CONST char *returnCodes[] = { "ok", "error", "return", "break", "continue", NULL @@ -1334,25 +1347,31 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); } - /* Check for bogus -level value */ + /* + * Check for bogus -level value. + */ + Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr); if (valuePtr != NULL) { - if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) + if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) || (level < 0)) { - /* Value is not a legal level */ + /* + * Value is not a legal level. + */ + Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad -level value: ", - "expected non-negative integer but got \"", - TclGetString(valuePtr), "\"", (char *) NULL); + "expected non-negative integer but got \"", + TclGetString(valuePtr), "\"", (char *) NULL); goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]); } - /* - * Convert [return -code return -level X] to - * [return -code ok -level X+1] + /* + * Convert [return -code return -level X] to [return -code ok -level X+1] */ + if (code == TCL_RETURN) { level++; code = TCL_OK; @@ -1364,15 +1383,19 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) if (levelPtr != NULL) { *levelPtr = level; } + if (optionsPtrPtr == NULL) { - /* Not passing back the options (?!), so clean them up */ + /* + * Not passing back the options (?!), so clean them up. + */ + Tcl_DecrRefCount(returnOpts); } else { *optionsPtrPtr = returnOpts; } return TCL_OK; -error: + error: Tcl_DecrRefCount(returnOpts); return TCL_ERROR; } @@ -1422,10 +1445,11 @@ Tcl_GetReturnOptions(interp, result) if (result == TCL_ERROR) { /* - * When result was an error, fill in any missing values - * for -errorinfo, -errorcode, and -errorline + * When result was an error, fill in any missing values for + * -errorinfo, -errorcode, and -errorline */ - Tcl_AddObjErrorInfo(interp, "", -1); + + Tcl_AddObjErrorInfo(interp, "", -1); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE], @@ -1439,14 +1463,14 @@ Tcl_GetReturnOptions(interp, result) * * Tcl_SetReturnOptions -- * - * Accepts an interp and a dictionary of return options, and sets - * the return options of the interp to match the dictionary. + * Accepts an interp and a dictionary of return options, and sets the + * return options of the interp to match the dictionary. * * Results: - * A standard status code. Usually TCL_OK, but TCL_ERROR if an - * invalid option value was found in the dictionary. If a -level - * value of 0 is in the dictionary, then the -code value in the - * dictionary will be returned (TCL_OK default). + * A standard status code. Usually TCL_OK, but TCL_ERROR if an invalid + * option value was found in the dictionary. If a -level value of 0 is in + * the dictionary, then the -code value in the dictionary will be + * returned (TCL_OK default). * * Side effects: * Sets the state of the interp. @@ -1484,21 +1508,20 @@ Tcl_SetReturnOptions(interp, options) * * TclTransferResult -- * - * Copy the result (and error information) from one interp to - * another. Used when one interp has caused another interp to - * evaluate a script and then wants to transfer the results back - * to itself. + * Copy the result (and error information) from one interp to another. + * Used when one interp has caused another interp to evaluate a script + * and then wants to transfer the results back to itself. * - * This routine copies the string reps of the result and error - * information. It does not simply increment the refcounts of the - * result and error information objects themselves. - * It is not legal to exchange objects between interps, because an - * object may be kept alive by one interp, but have an internal rep - * that is only valid while some other interp is alive. + * This routine copies the string reps of the result and error + * information. It does not simply increment the refcounts of the result + * and error information objects themselves. It is not legal to exchange + * objects between interps, because an object may be kept alive by one + * interp, but have an internal rep that is only valid while some other + * interp is alive. * * Results: * The target interp's result is set to a copy of the source interp's - * result. The source's errorInfo field may be transferred to the + * result. The source's errorInfo field may be transferred to the * target's errorInfo field, and the source's errorCode field may be * transferred to the target's errorCode field. * @@ -1507,19 +1530,19 @@ Tcl_SetReturnOptions(interp, options) * *------------------------------------------------------------------------- */ - + void TclTransferResult(sourceInterp, result, targetInterp) Tcl_Interp *sourceInterp; /* Interp whose result and error information - * should be moved to the target interp. - * After moving result, this interp's result + * should be moved to the target interp. + * After moving result, this interp's result * is reset. */ - int result; /* TCL_OK if just the result should be copied, - * TCL_ERROR if both the result and error + int result; /* TCL_OK if just the result should be copied, + * TCL_ERROR if both the result and error * information should be copied. */ - Tcl_Interp *targetInterp; /* Interp where result and error information - * should be stored. If source and target - * are the same, nothing is done. */ + Tcl_Interp *targetInterp; /* Interp where result and error information + * should be stored. If source and target are + * the same, nothing is done. */ { Interp *iPtr = (Interp *) targetInterp; @@ -1533,3 +1556,11 @@ TclTransferResult(sourceInterp, result, targetInterp) Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); Tcl_ResetResult(sourceInterp); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 0e8c1f1..b77620b 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1,59 +1,57 @@ -/* +/* * tclStringObj.c -- * - * This file contains procedures that implement string operations on Tcl - * objects. Some string operations work with UTF strings and others - * require Unicode format. Functions that require knowledge of the width + * This file contains functions that implement string operations on Tcl + * objects. Some string operations work with UTF strings and others + * require Unicode format. Functions that require knowledge of the width * of each character, such as indexing, operate on Unicode data. * - * A Unicode string is an internationalized string. Conceptually, a - * Unicode string is an array of 16-bit quantities organized as a sequence - * of properly formed UTF-8 characters. There is a one-to-one map between - * Unicode and UTF characters. Because Unicode characters have a fixed - * width, operations such as indexing operate on Unicode data. The String - * object is optimized for the case where each UTF char in a string is - * only one byte. In this case, we store the value of numChars, but we - * don't store the Unicode data (unless Tcl_GetUnicode is explicitly - * called). - * - * The String object type stores one or both formats. The default - * behavior is to store UTF. Once Unicode is calculated by a function, it + * A Unicode string is an internationalized string. Conceptually, a + * Unicode string is an array of 16-bit quantities organized as a + * sequence of properly formed UTF-8 characters. There is a one-to-one + * map between Unicode and UTF characters. Because Unicode characters + * have a fixed width, operations such as indexing operate on Unicode + * data. The String object is optimized for the case where each UTF char + * in a string is only one byte. In this case, we store the value of + * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode + * is explicitly called). + * + * The String object type stores one or both formats. The default + * behavior is to store UTF. Once Unicode is calculated by a function, it * is stored in the internal rep for future access (without an additional * O(n) cost). * * To allow many appends to be done to an object without constantly * reallocating the space for the string or Unicode representation, we * allocate double the space for the string or Unicode and use the - * internal representation to keep track of how much space is used - * vs. allocated. + * internal representation to keep track of how much space is used vs. + * allocated. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStringObj.c,v 1.37 2005/05/10 18:34:49 kennykb Exp $ */ + * RCS: @(#) $Id: tclStringObj.c,v 1.38 2005/07/24 22:56:43 dkf Exp $ */ #include "tclInt.h" /* - * Prototypes for procedures defined later in this file: + * Prototypes for functions defined later in this file: */ static void AppendUnicodeToUnicodeRep _ANSI_ARGS_(( - Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, + Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int appendNumChars)); static void AppendUnicodeToUtfRep _ANSI_ARGS_(( - Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, + Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int numChars)); static void AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr, - CONST char *bytes, int numBytes)); + CONST char *bytes, int numBytes)); static void AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr, - CONST char *bytes, int numBytes)); - + CONST char *bytes, int numBytes)); static void FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr)); - static void FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static void DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); @@ -63,54 +61,58 @@ static void UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * The structure below defines the string Tcl object type by means of - * procedures that can be invoked by generic object code. + * functions that can be invoked by generic object code. */ Tcl_ObjType tclStringType = { - "string", /* name */ - FreeStringInternalRep, /* freeIntRepPro */ - DupStringInternalRep, /* dupIntRepProc */ - UpdateStringOfString, /* updateStringProc */ - SetStringFromAny /* setFromAnyProc */ + "string", /* name */ + FreeStringInternalRep, /* freeIntRepPro */ + DupStringInternalRep, /* dupIntRepProc */ + UpdateStringOfString, /* updateStringProc */ + SetStringFromAny /* setFromAnyProc */ }; /* - * The following structure is the internal rep for a String object. - * It keeps track of how much memory has been used and how much has been - * allocated for the Unicode and UTF string to enable growing and - * shrinking of the UTF and Unicode reps of the String object with fewer - * mallocs. To optimize string length and indexing operations, this - * structure also stores the number of characters (same of UTF and Unicode!) - * once that value has been computed. + * The following structure is the internal rep for a String object. It keeps + * track of how much memory has been used and how much has been allocated for + * the Unicode and UTF string to enable growing and shrinking of the UTF and + * Unicode reps of the String object with fewer mallocs. To optimize string + * length and indexing operations, this structure also stores the number of + * characters (same of UTF and Unicode!) once that value has been computed. + * + * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16 + * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This + * can be officially modified by altering the definition of Tcl_UniChar in + * tcl.h, but do not do that unless you are sure what you're doing! */ typedef struct String { - int numChars; /* The number of chars in the string. - * -1 means this value has not been - * calculated. >= 0 means that there is a - * valid Unicode rep, or that the number - * of UTF bytes == the number of chars. */ - size_t allocated; /* The amount of space actually allocated - * for the UTF string (minus 1 byte for - * the termination char). */ - size_t uallocated; /* The amount of space actually allocated - * for the Unicode string (minus 2 bytes for - * the termination char). */ - int hasUnicode; /* Boolean determining whether the string - * has a Unicode representation. */ - Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual - * size of this field depends on the - * 'uallocated' field above. */ + int numChars; /* The number of chars in the string. -1 means + * this value has not been calculated. >= 0 + * means that there is a valid Unicode rep, or + * that the number of UTF bytes == the number + * of chars. */ + size_t allocated; /* The amount of space actually allocated for + * the UTF string (minus 1 byte for the + * termination char). */ + size_t uallocated; /* The amount of space actually allocated for + * the Unicode string (minus 2 bytes for the + * termination char). */ + int hasUnicode; /* Boolean determining whether the string has + * a Unicode representation. */ + Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual size + * of this field depends on the 'uallocated' + * field above. */ } String; #define STRING_UALLOC(numChars) \ - (numChars * sizeof(Tcl_UniChar)) + (numChars * sizeof(Tcl_UniChar)) #define STRING_SIZE(ualloc) \ - ((unsigned) (sizeof(String) - sizeof(Tcl_UniChar) + ualloc)) + ((unsigned) (sizeof(String) - sizeof(Tcl_UniChar) + ualloc)) #define GET_STRING(objPtr) \ - ((String *) (objPtr)->internalRep.otherValuePtr) + ((String *) (objPtr)->internalRep.otherValuePtr) #define SET_STRING(objPtr, stringPtr) \ - (objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr) + ((objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr)) /* * TCL STRING GROWTH ALGORITHM @@ -121,87 +123,82 @@ typedef struct String { * Attempt to allocate 2 * (originalLength + appendLength) * On failure: * attempt to allocate originalLength + 2*appendLength + - * TCL_GROWTH_MIN_ALLOC + * TCL_GROWTH_MIN_ALLOC * * This algorithm allows very good performance, as it rapidly increases the * memory allocated for a given string, which minimizes the number of - * reallocations that must be performed. However, using only the doubling - * algorithm can lead to a significant waste of memory. In particular, it - * may fail even when there is sufficient memory available to complete the - * append request (but there is not 2 * totalLength memory available). So when - * the doubling fails (because there is not enough memory available), the + * reallocations that must be performed. However, using only the doubling + * algorithm can lead to a significant waste of memory. In particular, it may + * fail even when there is sufficient memory available to complete the append + * request (but there is not 2*totalLength memory available). So when the + * doubling fails (because there is not enough memory available), the * algorithm requests a smaller amount of memory, which is still enough to - * cover the request, but which hopefully will be less than the total available - * memory. - * - * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling - * of very small appends. Without this extra slush factor, a sequence - * of several small appends would cause several memory allocations. - * As long as TCL_GROWTH_MIN_ALLOC is a reasonable size, we can - * avoid that behavior. + * cover the request, but which hopefully will be less than the total + * available memory. + * + * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very + * small appends. Without this extra slush factor, a sequence of several small + * appends would cause several memory allocations. As long as + * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior. * * The growth algorithm can be tuned by adjusting the following parameters: * * TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when - * the double allocation has failed. - * Default is 1024 (1 kilobyte). + * the double allocation has failed. Default is + * 1024 (1 kilobyte). */ + #ifndef TCL_GROWTH_MIN_ALLOC #define TCL_GROWTH_MIN_ALLOC 1024 #endif - /* *---------------------------------------------------------------------- * * Tcl_NewStringObj -- * - * This procedure is normally called when not debugging: i.e., when + * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new string object and * initializes it from the byte pointer and length arguments. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewStringObj. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewStringObj. * * Results: * A newly created string object is returned that has ref count zero. * * Side effects: - * The new object's internal string representation will be set to a - * copy of the length bytes starting at "bytes". If "length" is - * negative, use bytes up to the first NULL byte; i.e., assume "bytes" - * points to a C-style NULL-terminated string. The object's type is set - * to NULL. An extra NULL is added to the end of the new object's byte - * array. + * The new object's internal string representation will be set to a copy + * of the length bytes starting at "bytes". If "length" is negative, use + * bytes up to the first NULL byte; i.e., assume "bytes" points to a + * C-style NULL-terminated string. The object's type is set to NULL. An + * extra NULL is added to the end of the new object's byte array. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewStringObj - Tcl_Obj * Tcl_NewStringObj(bytes, length) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ int length; /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first - * NULL byte. */ + * when initializing the new object. If + * negative, use bytes up to the first NULL + * byte. */ { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); } - #else /* if not TCL_MEM_DEBUG */ - Tcl_Obj * Tcl_NewStringObj(bytes, length) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ int length; /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first - * NULL byte. */ + * when initializing the new object. If + * negative, use bytes up to the first NULL + * byte. */ { register Tcl_Obj *objPtr; @@ -218,45 +215,43 @@ Tcl_NewStringObj(bytes, length) * * Tcl_DbNewStringObj -- * - * This procedure is normally called when debugging: i.e., when + * This function is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new string objects. It is the - * same as the Tcl_NewStringObj procedure above except that it calls + * same as the Tcl_NewStringObj function above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewStringObj. * * Results: * A newly created string object is returned that has ref count zero. * * Side effects: - * The new object's internal string representation will be set to a - * copy of the length bytes starting at "bytes". If "length" is - * negative, use bytes up to the first NULL byte; i.e., assume "bytes" - * points to a C-style NULL-terminated string. The object's type is set - * to NULL. An extra NULL is added to the end of the new object's byte - * array. + * The new object's internal string representation will be set to a copy + * of the length bytes starting at "bytes". If "length" is negative, use + * bytes up to the first NULL byte; i.e., assume "bytes" points to a + * C-style NULL-terminated string. The object's type is set to NULL. An + * extra NULL is added to the end of the new object's byte array. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG - Tcl_Obj * Tcl_DbNewStringObj(bytes, length, file, line) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ int length; /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first - * NULL byte. */ + * when initializing the new object. If + * negative, use bytes up to the first NULL + * byte. */ CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + * function; used for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; @@ -267,21 +262,19 @@ Tcl_DbNewStringObj(bytes, length, file, line) TclInitStringRep(objPtr, bytes, length); return objPtr; } - #else /* if not TCL_MEM_DEBUG */ - Tcl_Obj * Tcl_DbNewStringObj(bytes, length, file, line) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ register int length; /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first - * NULL byte. */ + * when initializing the new object. If + * negative, use bytes up to the first NULL + * byte. */ CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + * function; used for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewStringObj(bytes, length); } @@ -292,14 +285,13 @@ Tcl_DbNewStringObj(bytes, length, file, line) * * Tcl_NewUnicodeObj -- * - * This procedure is creates a new String object and initializes - * it from the given Unicode String. If the Utf String is the same size - * as the Unicode string, don't duplicate the data. + * This function is creates a new String object and initializes it from + * the given Unicode String. If the Utf String is the same size as the + * Unicode string, don't duplicate the data. * * Results: - * The newly created object is returned. This object will have no - * initial string representation. The returned object has a ref count - * of 0. + * The newly created object is returned. This object will have no initial + * string representation. The returned object has a ref count of 0. * * Side effects: * Memory allocated for new object and copy of Unicode argument. @@ -309,8 +301,8 @@ Tcl_DbNewStringObj(bytes, length, file, line) Tcl_Obj * Tcl_NewUnicodeObj(unicode, numChars) - CONST Tcl_UniChar *unicode; /* The unicode string used to initialize - * the new object. */ + CONST Tcl_UniChar *unicode; /* The unicode string used to initialize the + * new object. */ int numChars; /* Number of characters in the unicode * string. */ { @@ -321,7 +313,9 @@ Tcl_NewUnicodeObj(unicode, numChars) if (numChars < 0) { numChars = 0; if (unicode) { - while (unicode[numChars] != 0) { numChars++; } + while (unicode[numChars] != 0) { + numChars++; + } } } uallocated = STRING_UALLOC(numChars); @@ -356,60 +350,61 @@ Tcl_NewUnicodeObj(unicode, numChars) * Pointer to unicode string representing the unicode object. * * Side effects: - * Frees old internal rep. Allocates memory for new "String" - * internal rep. + * Frees old internal rep. Allocates memory for new "String" internal + * rep. * *---------------------------------------------------------------------- */ int Tcl_GetCharLength(objPtr) - Tcl_Obj *objPtr; /* The String object to get the num chars of. */ + Tcl_Obj *objPtr; /* The String object to get the num chars + * of. */ { String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); /* - * If numChars is unknown, then calculate the number of characaters - * while populating the Unicode string. + * If numChars is unknown, then calculate the number of characaters while + * populating the Unicode string. */ - + if (stringPtr->numChars == -1) { register int i = objPtr->length; register unsigned char *str = (unsigned char *) objPtr->bytes; /* * This is a speed sensitive function, so run specially over the - * string to count continuous ascii characters before resorting - * to the Tcl_NumUtfChars call. This is a long form of: - stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length); - */ + * string to count continuous ascii characters before resorting to the + * Tcl_NumUtfChars call. This is a long form of: + stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes,objPtr->length); + */ - while (i && (*str < 0xC0)) { i--; str++; } + while (i && (*str < 0xC0)) { + i--; + str++; + } stringPtr->numChars = objPtr->length - i; if (i) { stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes + (objPtr->length - i), i); } - if (stringPtr->numChars == objPtr->length) { - + if (stringPtr->numChars == objPtr->length) { /* - * Since we've just calculated the number of chars, and all - * UTF chars are 1-byte long, we don't need to store the - * unicode string. + * Since we've just calculated the number of chars, and all UTF + * chars are 1-byte long, we don't need to store the unicode + * string. */ stringPtr->hasUnicode = 0; - } else { - /* - * Since we've just calucalated the number of chars, and not - * all UTF chars are 1-byte long, go ahead and populate the - * unicode string. + * Since we've just calucalated the number of chars, and not all + * UTF chars are 1-byte long, go ahead and populate the unicode + * string. */ FillUnicodeRep(objPtr); @@ -418,7 +413,7 @@ Tcl_GetCharLength(objPtr) * We need to fetch the pointer again because we have just * reallocated the structure to make room for the Unicode data. */ - + stringPtr = GET_STRING(objPtr); } } @@ -430,8 +425,8 @@ Tcl_GetCharLength(objPtr) * * Tcl_GetUniChar -- * - * Get the index'th Unicode character from the String object. The - * index is assumed to be in the appropriate range. + * Get the index'th Unicode character from the String object. The index + * is assumed to be in the appropriate range. * * Results: * Returns the index'th Unicode character in the Object. @@ -444,21 +439,20 @@ Tcl_GetCharLength(objPtr) Tcl_UniChar Tcl_GetUniChar(objPtr, index) - Tcl_Obj *objPtr; /* The object to get the Unicode charater from. */ - int index; /* Get the index'th Unicode character. */ + Tcl_Obj *objPtr; /* The object to get the Unicode charater + * from. */ + int index; /* Get the index'th Unicode character. */ { Tcl_UniChar unichar; String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == -1) { - /* - * We haven't yet calculated the length, so we don't have the - * Unicode str. We need to know the number of chars before we - * can do indexing. + * We haven't yet calculated the length, so we don't have the Unicode + * str. We need to know the number of chars before we can do indexing. */ Tcl_GetCharLength(objPtr); @@ -467,15 +461,14 @@ Tcl_GetUniChar(objPtr, index) * We need to fetch the pointer again because we may have just * reallocated the structure. */ - + stringPtr = GET_STRING(objPtr); } if (stringPtr->hasUnicode == 0) { - /* - * All of the characters in the Utf string are 1 byte chars, - * so we don't store the unicode char. We get the Utf string - * and convert the index'th byte to a Unicode character. + * All of the characters in the Utf string are 1 byte chars, so we + * don't store the unicode char. We get the Utf string and convert the + * index'th byte to a Unicode character. */ unichar = (Tcl_UniChar) objPtr->bytes[index]; @@ -490,10 +483,10 @@ Tcl_GetUniChar(objPtr, index) * * Tcl_GetUnicode -- * - * Get the Unicode form of the String object. If - * the object is not already a String object, it will be converted - * to one. If the String object does not have a Unicode rep, then - * one is create from the UTF string format. + * Get the Unicode form of the String object. If the object is not + * already a String object, it will be converted to one. If the String + * object does not have a Unicode rep, then one is create from the UTF + * string format. * * Results: * Returns a pointer to the object's internal Unicode string. @@ -506,30 +499,30 @@ Tcl_GetUniChar(objPtr, index) Tcl_UniChar * Tcl_GetUnicode(objPtr) - Tcl_Obj *objPtr; /* The object to find the unicode string for. */ + Tcl_Obj *objPtr; /* The object to find the unicode string + * for. */ { String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - - if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { + if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { /* - * We haven't yet calculated the length, or all of the characters - * in the Utf string are 1 byte chars (so we didn't store the - * unicode str). Since this function must return a unicode string, - * and one has not yet been stored, force the Unicode to be - * calculated and stored now. + * We haven't yet calculated the length, or all of the characters in + * the Utf string are 1 byte chars (so we didn't store the unicode + * str). Since this function must return a unicode string, and one has + * not yet been stored, force the Unicode to be calculated and stored + * now. */ FillUnicodeRep(objPtr); /* - * We need to fetch the pointer again because we have just - * reallocated the structure to make room for the Unicode data. + * We need to fetch the pointer again because we have just reallocated + * the structure to make room for the Unicode data. */ - + stringPtr = GET_STRING(objPtr); } return stringPtr->unicode; @@ -540,10 +533,10 @@ Tcl_GetUnicode(objPtr) * * Tcl_GetUnicodeFromObj -- * - * Get the Unicode form of the String object with length. If - * the object is not already a String object, it will be converted - * to one. If the String object does not have a Unicode rep, then - * one is create from the UTF string format. + * Get the Unicode form of the String object with length. If the object + * is not already a String object, it will be converted to one. If the + * String object does not have a Unicode rep, then one is create from the + * UTF string format. * * Results: * Returns a pointer to the object's internal Unicode string. @@ -556,33 +549,33 @@ Tcl_GetUnicode(objPtr) Tcl_UniChar * Tcl_GetUnicodeFromObj(objPtr, lengthPtr) - Tcl_Obj *objPtr; /* The object to find the unicode string for. */ - int *lengthPtr; /* If non-NULL, the location where the - * string rep's unichar length should be - * stored. If NULL, no length is stored. */ + Tcl_Obj *objPtr; /* The object to find the unicode string + * for. */ + int *lengthPtr; /* If non-NULL, the location where the string + * rep's unichar length should be stored. If + * NULL, no length is stored. */ { String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - - if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { + if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { /* - * We haven't yet calculated the length, or all of the characters - * in the Utf string are 1 byte chars (so we didn't store the - * unicode str). Since this function must return a unicode string, - * and one has not yet been stored, force the Unicode to be - * calculated and stored now. + * We haven't yet calculated the length, or all of the characters in + * the Utf string are 1 byte chars (so we didn't store the unicode + * str). Since this function must return a unicode string, and one has + * not yet been stored, force the Unicode to be calculated and stored + * now. */ FillUnicodeRep(objPtr); /* - * We need to fetch the pointer again because we have just - * reallocated the structure to make room for the Unicode data. + * We need to fetch the pointer again because we have just reallocated + * the structure to make room for the Unicode data. */ - + stringPtr = GET_STRING(objPtr); } @@ -597,10 +590,10 @@ Tcl_GetUnicodeFromObj(objPtr, lengthPtr) * * Tcl_GetRange -- * - * Create a Tcl Object that contains the chars between first and last - * of the object indicated by "objPtr". If the object is not already - * a String object, convert it to one. The first and last indices - * are assumed to be in the appropriate range. + * Create a Tcl Object that contains the chars between first and last of + * the object indicated by "objPtr". If the object is not already a + * String object, convert it to one. The first and last indices are + * assumed to be in the appropriate range. * * Results: * Returns a new Tcl Object of the String type. @@ -619,16 +612,14 @@ Tcl_GetRange(objPtr, first, last) { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == -1) { - /* - * We haven't yet calculated the length, so we don't have the - * Unicode str. We need to know the number of chars before we - * can do indexing. + * We haven't yet calculated the length, so we don't have the Unicode + * str. We need to know the number of chars before we can do indexing. */ Tcl_GetCharLength(objPtr); @@ -637,7 +628,7 @@ Tcl_GetRange(objPtr, first, last) * We need to fetch the pointer again because we may have just * reallocated the structure. */ - + stringPtr = GET_STRING(objPtr); } @@ -645,18 +636,18 @@ Tcl_GetRange(objPtr, first, last) char *str = Tcl_GetString(objPtr); /* - * All of the characters in the Utf string are 1 byte chars, - * so we don't store the unicode char. Create a new string - * object containing the specified range of chars. + * All of the characters in the Utf string are 1 byte chars, so we + * don't store the unicode char. Create a new string object containing + * the specified range of chars. */ - + newObjPtr = Tcl_NewStringObj(&str[first], last-first+1); /* - * Since we know the new string only has 1-byte chars, we - * can set it's numChars field. + * Since we know the new string only has 1-byte chars, we can set it's + * numChars field. */ - + SetStringFromAny(NULL, newObjPtr); stringPtr = GET_STRING(newObjPtr); stringPtr->numChars = last-first+1; @@ -673,16 +664,16 @@ Tcl_GetRange(objPtr, first, last) * Tcl_SetStringObj -- * * Modify an object to hold a string that is a copy of the bytes - * indicated by the byte pointer and length arguments. + * indicated by the byte pointer and length arguments. * * Results: * None. * * Side effects: - * The object's string representation will be set to a copy of - * the "length" bytes starting at "bytes". If "length" is negative, use - * bytes up to the first NULL byte; i.e., assume "bytes" points to a - * C-style NULL-terminated string. The object's old string and internal + * The object's string representation will be set to a copy of the + * "length" bytes starting at "bytes". If "length" is negative, use bytes + * up to the first NULL byte; i.e., assume "bytes" points to a C-style + * NULL-terminated string. The object's old string and internal * representations are freed and the object's type is set NULL. * *---------------------------------------------------------------------- @@ -694,13 +685,12 @@ Tcl_SetStringObj(objPtr, bytes, length) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the object. */ register int length; /* The number of bytes to copy from "bytes" - * when initializing the object. If - * negative, use bytes up to the first - * NULL byte.*/ + * when initializing the object. If negative, + * use bytes up to the first NULL byte.*/ { /* - * Free any old string rep, then set the string rep to a copy of - * the length bytes starting at "bytes". + * Free any old string rep, then set the string rep to a copy of the + * length bytes starting at "bytes". */ if (Tcl_IsShared(objPtr)) { @@ -726,20 +716,19 @@ Tcl_SetStringObj(objPtr, bytes, length) * * Tcl_SetObjLength -- * - * This procedure changes the length of the string representation - * of an object. + * This function changes the length of the string representation of an + * object. * * Results: * None. * * Side effects: - * If the size of objPtr's string representation is greater than - * length, then it is reduced to length and a new terminating null - * byte is stored in the strength. If the length of the string - * representation is greater than length, the storage space is - * reallocated to the given length; a null byte is stored at the - * end, but other bytes past the end of the original string - * representation are undefined. The object's internal + * If the size of objPtr's string representation is greater than length, + * then it is reduced to length and a new terminating null byte is stored + * in the strength. If the length of the string representation is greater + * than length, the storage space is reallocated to the given length; a + * null byte is stored at the end, but other bytes past the end of the + * original string representation are undefined. The object's internal * representation is changed to "expendable string". * *---------------------------------------------------------------------- @@ -747,8 +736,8 @@ Tcl_SetStringObj(objPtr, bytes, length) void Tcl_SetObjLength(objPtr, length) - register Tcl_Obj *objPtr; /* Pointer to object. This object must - * not currently be shared. */ + register Tcl_Obj *objPtr; /* Pointer to object. This object must not + * currently be shared. */ register int length; /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ @@ -759,19 +748,22 @@ Tcl_SetObjLength(objPtr, length) Tcl_Panic("Tcl_SetObjLength called with shared object"); } SetStringFromAny(NULL, objPtr); - + stringPtr = GET_STRING(objPtr); - - /* Check that we're not extending a pure unicode string */ - - if (length > (int) stringPtr->allocated && + + /* + * Check that we're not extending a pure unicode string. + */ + + if (length > (int) stringPtr->allocated && (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) { char *new; /* - * Not enough space in current string. Reallocate the string - * space and free the old string. + * Not enough space in current string. Reallocate the string space and + * free the old string. */ + if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) { new = (char *) ckrealloc((char *)objPtr->bytes, (unsigned)(length+1)); @@ -785,34 +777,53 @@ Tcl_SetObjLength(objPtr, length) } objPtr->bytes = new; stringPtr->allocated = length; - /* Invalidate the unicode data. */ + + /* + * Invalidate the unicode data. + */ + stringPtr->hasUnicode = 0; } - + if (objPtr->bytes != NULL) { - objPtr->length = length; - if (objPtr->bytes != tclEmptyStringRep) { - /* Ensure the string is NULL-terminated */ - objPtr->bytes[length] = 0; - } - /* Invalidate the unicode data. */ - stringPtr->numChars = -1; - stringPtr->hasUnicode = 0; + objPtr->length = length; + if (objPtr->bytes != tclEmptyStringRep) { + /* + * Ensure the string is NULL-terminated. + */ + + objPtr->bytes[length] = 0; + } + + /* + * Invalidate the unicode data. + */ + + stringPtr->numChars = -1; + stringPtr->hasUnicode = 0; } else { - /* Changing length of pure unicode string */ - size_t uallocated = STRING_UALLOC(length); - if (uallocated > stringPtr->uallocated) { - stringPtr = (String *) ckrealloc((char*) stringPtr, - STRING_SIZE(uallocated)); - SET_STRING(objPtr, stringPtr); - stringPtr->uallocated = uallocated; - } - stringPtr->numChars = length; - stringPtr->hasUnicode = (length > 0); - /* Ensure the string is NULL-terminated */ - stringPtr->unicode[length] = 0; - stringPtr->allocated = 0; - objPtr->length = 0; + /* + * Changing length of pure unicode string. + */ + + size_t uallocated = STRING_UALLOC(length); + + if (uallocated > stringPtr->uallocated) { + stringPtr = (String *) ckrealloc((char*) stringPtr, + STRING_SIZE(uallocated)); + SET_STRING(objPtr, stringPtr); + stringPtr->uallocated = uallocated; + } + stringPtr->numChars = length; + stringPtr->hasUnicode = (length > 0); + + /* + * Ensure the string is NULL-terminated. + */ + + stringPtr->unicode[length] = 0; + stringPtr->allocated = 0; + objPtr->length = 0; } } @@ -821,20 +832,19 @@ Tcl_SetObjLength(objPtr, length) * * Tcl_AttemptSetObjLength -- * - * This procedure changes the length of the string representation - * of an object. It uses the attempt* (non-panic'ing) memory allocators. + * This function changes the length of the string representation of an + * object. It uses the attempt* (non-panic'ing) memory allocators. * * Results: * 1 if the requested memory was allocated, 0 otherwise. * * Side effects: - * If the size of objPtr's string representation is greater than - * length, then it is reduced to length and a new terminating null - * byte is stored in the strength. If the length of the string - * representation is greater than length, the storage space is - * reallocated to the given length; a null byte is stored at the - * end, but other bytes past the end of the original string - * representation are undefined. The object's internal + * If the size of objPtr's string representation is greater than length, + * then it is reduced to length and a new terminating null byte is stored + * in the strength. If the length of the string representation is greater + * than length, the storage space is reallocated to the given length; a + * null byte is stored at the end, but other bytes past the end of the + * original string representation are undefined. The object's internal * representation is changed to "expendable string". * *---------------------------------------------------------------------- @@ -842,8 +852,8 @@ Tcl_SetObjLength(objPtr, length) int Tcl_AttemptSetObjLength(objPtr, length) - register Tcl_Obj *objPtr; /* Pointer to object. This object must - * not currently be shared. */ + register Tcl_Obj *objPtr; /* Pointer to object. This object must not + * currently be shared. */ register int length; /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ @@ -854,19 +864,22 @@ Tcl_AttemptSetObjLength(objPtr, length) Tcl_Panic("Tcl_AttemptSetObjLength called with shared object"); } SetStringFromAny(NULL, objPtr); - + stringPtr = GET_STRING(objPtr); - /* Check that we're not extending a pure unicode string */ + /* + * Check that we're not extending a pure unicode string. + */ - if (length > (int) stringPtr->allocated && + if (length > (int) stringPtr->allocated && (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) { char *new; /* - * Not enough space in current string. Reallocate the string - * space and free the old string. + * Not enough space in current string. Reallocate the string space and + * free the old string. */ + if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) { new = (char *) attemptckrealloc((char *)objPtr->bytes, (unsigned)(length+1)); @@ -879,41 +892,60 @@ Tcl_AttemptSetObjLength(objPtr, length) return 0; } if (objPtr->bytes != NULL && objPtr->length != 0) { - memcpy((VOID *) new, (VOID *) objPtr->bytes, - (size_t) objPtr->length); - Tcl_InvalidateStringRep(objPtr); + memcpy((VOID *) new, (VOID *) objPtr->bytes, + (size_t) objPtr->length); + Tcl_InvalidateStringRep(objPtr); } } objPtr->bytes = new; stringPtr->allocated = length; - /* Invalidate the unicode data. */ + + /* + * Invalidate the unicode data. + */ + stringPtr->hasUnicode = 0; } - + if (objPtr->bytes != NULL) { objPtr->length = length; if (objPtr->bytes != tclEmptyStringRep) { - /* Ensure the string is NULL-terminated */ + /* + * Ensure the string is NULL-terminated. + */ + objPtr->bytes[length] = 0; } - /* Invalidate the unicode data. */ + + /* + * Invalidate the unicode data. + */ + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; } else { - /* Changing length of pure unicode string */ + /* + * Changing length of pure unicode string. + */ + size_t uallocated = STRING_UALLOC(length); + if (uallocated > stringPtr->uallocated) { stringPtr = (String *) attemptckrealloc((char*) stringPtr, STRING_SIZE(uallocated)); if (stringPtr == NULL) { - return 0; + return 0; } SET_STRING(objPtr, stringPtr); stringPtr->uallocated = uallocated; } stringPtr->numChars = length; stringPtr->hasUnicode = (length > 0); - /* Ensure the string is NULL-terminated */ + + /* + * Ensure the string is NULL-terminated. + */ + stringPtr->unicode[length] = 0; stringPtr->allocated = 0; objPtr->length = 0; @@ -940,8 +972,8 @@ Tcl_AttemptSetObjLength(objPtr, length) void Tcl_SetUnicodeObj(objPtr, unicode, numChars) Tcl_Obj *objPtr; /* The object to set the string of. */ - CONST Tcl_UniChar *unicode; /* The unicode string used to initialize - * the object. */ + CONST Tcl_UniChar *unicode; /* The unicode string used to initialize the + * object. */ int numChars; /* Number of characters in the unicode * string. */ { @@ -951,7 +983,9 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars) if (numChars < 0) { numChars = 0; if (unicode) { - while (unicode[numChars] != 0) { numChars++; } + while (unicode[numChars] != 0) { + numChars++; + } } } uallocated = STRING_UALLOC(numChars); @@ -966,7 +1000,7 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars) /* * Allocate enough space for the String structure + Unicode string. */ - + stringPtr = (String *) ckalloc(STRING_SIZE(uallocated)); stringPtr->numChars = numChars; stringPtr->uallocated = uallocated; @@ -974,6 +1008,7 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars) stringPtr->allocated = 0; memcpy((VOID *) stringPtr->unicode, (VOID *) unicode, uallocated); stringPtr->unicode[numChars] = 0; + SET_STRING(objPtr, stringPtr); Tcl_InvalidateStringRep(objPtr); return; @@ -984,15 +1019,15 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars) * * TclAppendLimitedToObj -- * - * This procedure appends a limited number of bytes from a sequence - * of bytes to an object, marking any limitation with an ellipsis. + * This function appends a limited number of bytes from a sequence of + * bytes to an object, marking any limitation with an ellipsis. * * Results: * None. * * Side effects: - * The bytes at *bytes are appended to the string representation - * of objPtr. + * The bytes at *bytes are appended to the string representation of + * objPtr. * *---------------------------------------------------------------------- */ @@ -1003,13 +1038,13 @@ TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis) CONST char *bytes; /* Points to the bytes to append to the * object. */ register int length; /* The number of bytes available to be - * appended from "bytes". If < 0, then - * all bytes up to a NULL byte are available. */ - register int limit; /* The maximum number of bytes to append - * to the object. */ - CONST char *ellipsis; /* Ellipsis marker string, appended to - * the object to indicate not all available - * bytes at "bytes" were appended. */ + * appended from "bytes". If < 0, then all + * bytes up to a NULL byte are available. */ + register int limit; /* The maximum number of bytes to append to + * the object. */ + CONST char *ellipsis; /* Ellipsis marker string, appended to the + * object to indicate not all available bytes + * at "bytes" were appended. */ { String *stringPtr; int toCopy = 0; @@ -1037,9 +1072,9 @@ TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis) } /* - * If objPtr has a valid Unicode rep, then append the Unicode - * conversion of "bytes" to the objPtr's Unicode rep, otherwise - * append "bytes" to objPtr's string rep. + * If objPtr has a valid Unicode rep, then append the Unicode conversion + * of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to + * objPtr's string rep. */ stringPtr = GET_STRING(objPtr); @@ -1059,7 +1094,6 @@ TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis) } else { AppendUtfToUtfRep(objPtr, ellipsis, -1); } - } /* @@ -1067,14 +1101,14 @@ TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis) * * Tcl_AppendToObj -- * - * This procedure appends a sequence of bytes to an object. + * This function appends a sequence of bytes to an object. * * Results: * None. * * Side effects: - * The bytes at *bytes are appended to the string representation - * of objPtr. + * The bytes at *bytes are appended to the string representation of + * objPtr. * *---------------------------------------------------------------------- */ @@ -1084,9 +1118,9 @@ Tcl_AppendToObj(objPtr, bytes, length) register Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST char *bytes; /* Points to the bytes to append to the * object. */ - register int length; /* The number of bytes to append from - * "bytes". If < 0, then append all bytes - * up to NULL byte. */ + register int length; /* The number of bytes to append from "bytes". + * If < 0, then append all bytes up to NULL + * byte. */ { TclAppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL); } @@ -1096,8 +1130,8 @@ Tcl_AppendToObj(objPtr, bytes, length) * * Tcl_AppendUnicodeToObj -- * - * This procedure appends a Unicode string to an object in the - * most efficient manner possible. Length must be >= 0. + * This function appends a Unicode string to an object in the most + * efficient manner possible. Length must be >= 0. * * Results: * None. @@ -1112,7 +1146,7 @@ void Tcl_AppendUnicodeToObj(objPtr, unicode, length) register Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST Tcl_UniChar *unicode; /* The unicode string to append to the - * object. */ + * object. */ int length; /* Number of chars in "unicode". */ { String *stringPtr; @@ -1129,9 +1163,9 @@ Tcl_AppendUnicodeToObj(objPtr, unicode, length) stringPtr = GET_STRING(objPtr); /* - * If objPtr has a valid Unicode rep, then append the "unicode" - * to the objPtr's Unicode rep, otherwise the UTF conversion of - * "unicode" to objPtr's string rep. + * If objPtr has a valid Unicode rep, then append the "unicode" to the + * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to + * objPtr's string rep. */ if (stringPtr->hasUnicode != 0) { @@ -1146,14 +1180,14 @@ Tcl_AppendUnicodeToObj(objPtr, unicode, length) * * Tcl_AppendObjToObj -- * - * This procedure appends the string rep of one object to another. + * This function appends the string rep of one object to another. * "objPtr" cannot be a shared object. * * Results: * None. * * Side effects: - * The string rep of appendObjPtr is appended to the string + * The string rep of appendObjPtr is appended to the string * representation of objPtr. * *---------------------------------------------------------------------- @@ -1171,25 +1205,22 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr) SetStringFromAny(NULL, objPtr); /* - * If objPtr has a valid Unicode rep, then get a Unicode string - * from appendObjPtr and append it. + * If objPtr has a valid Unicode rep, then get a Unicode string from + * appendObjPtr and append it. */ stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode != 0) { - /* * If appendObjPtr is not of the "String" type, don't convert it. */ if (appendObjPtr->typePtr == &tclStringType) { stringPtr = GET_STRING(appendObjPtr); - if ((stringPtr->numChars == -1) - || (stringPtr->hasUnicode == 0)) { - + if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { /* - * If appendObjPtr is a string obj with no valid Unicode - * rep, then fill its unicode rep. + * If appendObjPtr is a string obj with no valid Unicode rep, + * then fill its unicode rep. */ FillUnicodeRep(appendObjPtr); @@ -1205,9 +1236,9 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr) } /* - * Append to objPtr's UTF string rep. If we know the number of - * characters in both objects before appending, then set the combined - * number of characters in the final (appended-to) object. + * Append to objPtr's UTF string rep. If we know the number of characters + * in both objects before appending, then set the combined number of + * characters in the final (appended-to) object. */ bytes = Tcl_GetStringFromObj(appendObjPtr, &length); @@ -1235,8 +1266,8 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr) * * AppendUnicodeToUnicodeRep -- * - * This procedure appends the contents of "unicode" to the Unicode - * rep of "objPtr". objPtr must already have a valid Unicode rep. + * This function appends the contents of "unicode" to the Unicode rep of + * "objPtr". objPtr must already have a valid Unicode rep. * * Results: * None. @@ -1249,9 +1280,9 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr) static void AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - CONST Tcl_UniChar *unicode; /* String to append. */ - int appendNumChars; /* Number of chars of "unicode" to append. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST Tcl_UniChar *unicode; /* String to append. */ + int appendNumChars; /* Number of chars of "unicode" to append. */ { String *stringPtr, *tmpString; size_t numChars; @@ -1259,7 +1290,9 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) if (appendNumChars < 0) { appendNumChars = 0; if (unicode) { - while (unicode[appendNumChars] != 0) { appendNumChars++; } + while (unicode[appendNumChars] != 0) { + appendNumChars++; + } } } if (appendNumChars == 0) { @@ -1270,23 +1303,23 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) stringPtr = GET_STRING(objPtr); /* - * If not enough space has been allocated for the unicode rep, - * reallocate the internal rep object with additional space. First - * try to double the required allocation; if that fails, try a more - * modest increase. See the "TCL STRING GROWTH ALGORITHM" comment at - * the top of this file for an explanation of this growth algorithm. + * If not enough space has been allocated for the unicode rep, reallocate + * the internal rep object with additional space. First try to double the + * required allocation; if that fails, try a more modest increase. See the + * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an + * explanation of this growth algorithm. */ numChars = stringPtr->numChars + appendNumChars; if (STRING_UALLOC(numChars) >= stringPtr->uallocated) { - stringPtr->uallocated = STRING_UALLOC(2 * numChars); + stringPtr->uallocated = STRING_UALLOC(2 * numChars); tmpString = (String *) attemptckrealloc((char *)stringPtr, STRING_SIZE(stringPtr->uallocated)); if (tmpString == NULL) { stringPtr->uallocated = - STRING_UALLOC(numChars + appendNumChars) - + TCL_GROWTH_MIN_ALLOC; + STRING_UALLOC(numChars + appendNumChars) + + TCL_GROWTH_MIN_ALLOC; tmpString = (String *) ckrealloc((char *)stringPtr, STRING_SIZE(stringPtr->uallocated)); } @@ -1312,8 +1345,8 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) * * AppendUnicodeToUtfRep -- * - * This procedure converts the contents of "unicode" to UTF and - * appends the UTF to the string rep of "objPtr". + * This function converts the contents of "unicode" to UTF and appends + * the UTF to the string rep of "objPtr". * * Results: * None. @@ -1326,17 +1359,19 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) static void AppendUnicodeToUtfRep(objPtr, unicode, numChars) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - CONST Tcl_UniChar *unicode; /* String to convert to UTF. */ - int numChars; /* Number of chars of "unicode" to convert. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST Tcl_UniChar *unicode; /* String to convert to UTF. */ + int numChars; /* Number of chars of "unicode" to convert. */ { Tcl_DString dsPtr; CONST char *bytes; - + if (numChars < 0) { numChars = 0; if (unicode) { - while (unicode[numChars] != 0) { numChars++; } + while (unicode[numChars] != 0) { + numChars++; + } } } if (numChars == 0) { @@ -1354,9 +1389,9 @@ AppendUnicodeToUtfRep(objPtr, unicode, numChars) * * AppendUtfToUnicodeRep -- * - * This procedure converts the contents of "bytes" to Unicode and - * appends the Unicode to the Unicode rep of "objPtr". objPtr must - * already have a valid Unicode rep. + * This function converts the contents of "bytes" to Unicode and appends + * the Unicode to the Unicode rep of "objPtr". objPtr must already have a + * valid Unicode rep. * * Results: * None. @@ -1369,9 +1404,9 @@ AppendUnicodeToUtfRep(objPtr, unicode, numChars) static void AppendUtfToUnicodeRep(objPtr, bytes, numBytes) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - CONST char *bytes; /* String to convert to Unicode. */ - int numBytes; /* Number of bytes of "bytes" to convert. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST char *bytes; /* String to convert to Unicode. */ + int numBytes; /* Number of bytes of "bytes" to convert. */ { Tcl_DString dsPtr; int numChars; @@ -1383,7 +1418,7 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes) if (numBytes == 0) { return; } - + Tcl_DStringInit(&dsPtr); numChars = Tcl_NumUtfChars(bytes, numBytes); unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr); @@ -1396,8 +1431,8 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes) * * AppendUtfToUtfRep -- * - * This procedure appends "numBytes" bytes of "bytes" to the UTF string - * rep of "objPtr". objPtr must already have a valid String rep. + * This function appends "numBytes" bytes of "bytes" to the UTF string + * rep of "objPtr". objPtr must already have a valid String rep. * * Results: * None. @@ -1410,9 +1445,9 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes) static void AppendUtfToUtfRep(objPtr, bytes, numBytes) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - CONST char *bytes; /* String to append. */ - int numBytes; /* Number of bytes of "bytes" to append. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST char *bytes; /* String to append. */ + int numBytes; /* Number of bytes of "bytes" to append. */ { String *stringPtr; int newLength, oldLength; @@ -1434,12 +1469,11 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes) stringPtr = GET_STRING(objPtr); if (newLength > (int) stringPtr->allocated) { - /* - * There isn't currently enough space in the string representation - * so allocate additional space. First, try to double the length - * required. If that fails, try a more modest allocation. See the - * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an + * There isn't currently enough space in the string representation so + * allocate additional space. First, try to double the length + * required. If that fails, try a more modest allocation. See the "TCL + * STRING GROWTH ALGORITHM" comment at the top of this file for an * explanation of this growth algorithm. */ @@ -1452,10 +1486,10 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes) /* * Invalidate the unicode data. */ - + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; - + memcpy((VOID *) (objPtr->bytes + oldLength), (VOID *) bytes, (size_t) numBytes); objPtr->bytes[newLength] = 0; @@ -1467,15 +1501,15 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes) * * Tcl_AppendStringsToObjVA -- * - * This procedure appends one or more null-terminated strings - * to an object. + * This function appends one or more null-terminated strings to an + * object. * * Results: * None. * * Side effects: - * The contents of all the string arguments are appended to the - * string representation of objPtr. + * The contents of all the string arguments are appended to the string + * representation of objPtr. * *---------------------------------------------------------------------- */ @@ -1501,10 +1535,10 @@ Tcl_AppendStringsToObjVA (objPtr, argList) SetStringFromAny(NULL, objPtr); /* - * Figure out how much space is needed for all the strings, and - * expand the string representation if it isn't big enough. If no - * bytes would be appended, just return. Note that on some platforms - * (notably OS/390) the argList is an array so we need to use memcpy. + * Figure out how much space is needed for all the strings, and expand the + * string representation if it isn't big enough. If no bytes would be + * appended, just return. Note that on some platforms (notably OS/390) the + * argList is an array so we need to use memcpy. */ nargs = 0; @@ -1515,21 +1549,22 @@ Tcl_AppendStringsToObjVA (objPtr, argList) if (string == NULL) { break; } - if (nargs >= nargs_space) { - /* - * Expand the args buffer - */ - nargs_space += STATIC_LIST_SIZE; - if (args == static_list) { - args = (void *)ckalloc(nargs_space * sizeof(char *)); - for (i = 0; i < nargs; ++i) { - args[i] = static_list[i]; - } - } else { - args = (void *)ckrealloc((void *)args, + if (nargs >= nargs_space) { + /* + * Expand the args buffer. + */ + + nargs_space += STATIC_LIST_SIZE; + if (args == static_list) { + args = (void *) ckalloc(nargs_space * sizeof(char *)); + for (i = 0; i < nargs; ++i) { + args[i] = static_list[i]; + } + } else { + args = (void *) ckrealloc((void *) args, nargs_space * sizeof(char *)); - } - } + } + } newLength += strlen(string); args[nargs++] = string; } @@ -1539,17 +1574,16 @@ Tcl_AppendStringsToObjVA (objPtr, argList) stringPtr = GET_STRING(objPtr); if (oldLength + newLength > (int) stringPtr->allocated) { - /* - * There isn't currently enough space in the string - * representation, so allocate additional space. If the current - * string representation isn't empty (i.e. it looks like we're - * doing a series of appends) then try to allocate extra space to - * accomodate future growth: first try to double the required memory; - * if that fails, try a more modest allocation. See the "TCL STRING - * GROWTH ALGORITHM" comment at the top of this file for an explanation - * of this growth algorithm. Otherwise, if the current string - * representation is empty, exactly enough memory is allocated. + * There isn't currently enough space in the string representation, so + * allocate additional space. If the current string representation + * isn't empty (i.e. it looks like we're doing a series of appends) + * then try to allocate extra space to accomodate future growth: first + * try to double the required memory; if that fails, try a more modest + * allocation. See the "TCL STRING GROWTH ALGORITHM" comment at the + * top of this file for an explanation of this growth algorithm. + * Otherwise, if the current string representation is empty, exactly + * enough memory is allocated. */ if (oldLength == 0) { @@ -1558,20 +1592,20 @@ Tcl_AppendStringsToObjVA (objPtr, argList) attemptLength = 2 * (oldLength + newLength); if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) { attemptLength = oldLength + (2 * newLength) + - TCL_GROWTH_MIN_ALLOC; + TCL_GROWTH_MIN_ALLOC; Tcl_SetObjLength(objPtr, attemptLength); } } } /* - * Make a second pass through the arguments, appending all the - * strings to the object. + * Make a second pass through the arguments, appending all the strings to + * the object. */ dst = objPtr->bytes + oldLength; for (i = 0; i < nargs; ++i) { - string = args[i]; + string = args[i]; if (string == NULL) { break; } @@ -1583,10 +1617,10 @@ Tcl_AppendStringsToObjVA (objPtr, argList) } /* - * Add a null byte to terminate the string. However, be careful: - * it's possible that the object is totally empty (if it was empty - * originally and there was nothing to append). In this case dst is - * NULL; just leave everything alone. + * Add a null byte to terminate the string. However, be careful: it's + * possible that the object is totally empty (if it was empty originally + * and there was nothing to append). In this case dst is NULL; just leave + * everything alone. */ if (dst != NULL) { @@ -1594,14 +1628,13 @@ Tcl_AppendStringsToObjVA (objPtr, argList) } objPtr->length = oldLength + newLength; - done: + done: /* - * If we had to allocate a buffer from the heap, - * free it now. + * If we had to allocate a buffer from the heap, free it now. */ - + if (args != static_list) { - ckfree((void *)args); + ckfree((void *)args); } #undef STATIC_LIST_SIZE } @@ -1611,15 +1644,15 @@ Tcl_AppendStringsToObjVA (objPtr, argList) * * Tcl_AppendStringsToObj -- * - * This procedure appends one or more null-terminated strings - * to an object. + * This function appends one or more null-terminated strings to an + * object. * * Results: * None. * * Side effects: - * The contents of all the string arguments are appended to the - * string representation of objPtr. + * The contents of all the string arguments are appended to the string + * representation of objPtr. * *---------------------------------------------------------------------- */ @@ -1641,7 +1674,7 @@ Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1) * FillUnicodeRep -- * * Populate the Unicode internal rep with the Unicode form of its string - * rep. The object must alread have a "String" internal rep. + * rep. The object must alread have a "String" internal rep. * * Results: * None. @@ -1654,14 +1687,15 @@ Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1) static void FillUnicodeRep(objPtr) - Tcl_Obj *objPtr; /* The object in which to fill the unicode rep. */ + Tcl_Obj *objPtr; /* The object in which to fill the unicode + * rep. */ { String *stringPtr; size_t uallocated; char *src, *srcEnd; Tcl_UniChar *dst; src = objPtr->bytes; - + stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == -1) { stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length); @@ -1670,18 +1704,15 @@ FillUnicodeRep(objPtr) uallocated = STRING_UALLOC(stringPtr->numChars); if (uallocated > stringPtr->uallocated) { - /* * If not enough space has been allocated for the unicode rep, * reallocate the internal rep object. - */ - - /* - * There isn't currently enough space in the Unicode - * representation so allocate additional space. If the current - * Unicode representation isn't empty (i.e. it looks like we've - * done some appends) then overallocate the space so - * that we won't have to do as much reallocation in the future. + * + * There isn't currently enough space in the Unicode representation so + * allocate additional space. If the current Unicode representation + * isn't empty (i.e. it looks like we've done some appends) then + * overallocate the space so that we won't have to do as much + * reallocation in the future. */ if (stringPtr->uallocated > 0) { @@ -1695,13 +1726,13 @@ FillUnicodeRep(objPtr) /* * Convert src to Unicode and store the coverted data in "unicode". */ - + srcEnd = src + objPtr->length; for (dst = stringPtr->unicode; src < srcEnd; dst++) { src += TclUtfToUniChar(src, dst); } *dst = 0; - + SET_STRING(objPtr, stringPtr); } @@ -1710,8 +1741,8 @@ FillUnicodeRep(objPtr) * * DupStringInternalRep -- * - * Initialize the internal representation of a new Tcl_Obj to a - * copy of the internal representation of an existing string object. + * Initialize the internal representation of a new Tcl_Obj to a copy of + * the internal representation of an existing string object. * * Results: * None. @@ -1725,27 +1756,27 @@ FillUnicodeRep(objPtr) static void DupStringInternalRep(srcPtr, copyPtr) - register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must - * have an internal rep of type "String". */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must - * not currently have an internal rep.*/ + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must have + * an internal rep of type "String". */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must not + * currently have an internal rep.*/ { String *srcStringPtr = GET_STRING(srcPtr); String *copyStringPtr = NULL; /* - * If the src obj is a string of 1-byte Utf chars, then copy the - * string rep of the source object and create an "empty" Unicode - * internal rep for the new object. Otherwise, copy Unicode - * internal rep, and invalidate the string rep of the new object. + * If the src obj is a string of 1-byte Utf chars, then copy the string + * rep of the source object and create an "empty" Unicode internal rep for + * the new object. Otherwise, copy Unicode internal rep, and invalidate + * the string rep of the new object. */ - + if (srcStringPtr->hasUnicode == 0) { - copyStringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0))); + copyStringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0))); copyStringPtr->uallocated = STRING_UALLOC(0); } else { copyStringPtr = (String *) ckalloc( - STRING_SIZE(srcStringPtr->uallocated)); + STRING_SIZE(srcStringPtr->uallocated)); copyStringPtr->uallocated = srcStringPtr->uallocated; memcpy((VOID *) copyStringPtr->unicode, @@ -1758,9 +1789,9 @@ DupStringInternalRep(srcPtr, copyPtr) copyStringPtr->allocated = srcStringPtr->allocated; /* - * Tricky point: the string value was copied by generic object - * management code, so it doesn't contain any extra bytes that - * might exist in the source object. + * Tricky point: the string value was copied by generic object management + * code, so it doesn't contain any extra bytes that might exist in the + * source object. */ copyStringPtr->allocated = copyPtr->length; @@ -1780,8 +1811,8 @@ DupStringInternalRep(srcPtr, copyPtr) * This operation always succeeds and returns TCL_OK. * * Side effects: - * Any old internal reputation for objPtr is freed and the - * internal representation is set to "String". + * Any old internal reputation for objPtr is freed and the internal + * representation is set to "String". * *---------------------------------------------------------------------- */ @@ -1792,9 +1823,9 @@ SetStringFromAny(interp, objPtr) register Tcl_Obj *objPtr; /* The object to convert. */ { /* - * The Unicode object is optimized for the case where each UTF char - * in a string is only one byte. In this case, we store the value of - * numChars, but we don't copy the bytes to the unicodeObj->unicode. + * The Unicode object is optimized for the case where each UTF char in a + * string is only one byte. In this case, we store the value of numChars, + * but we don't copy the bytes to the unicodeObj->unicode. */ if (objPtr->typePtr != &tclStringType) { @@ -1818,8 +1849,8 @@ SetStringFromAny(interp, objPtr) stringPtr->hasUnicode = 0; if (objPtr->bytes != NULL) { - stringPtr->allocated = objPtr->length; - objPtr->bytes[objPtr->length] = 0; + stringPtr->allocated = objPtr->length; + objPtr->bytes[objPtr->length] = 0; } else { objPtr->length = 0; } @@ -1840,8 +1871,8 @@ SetStringFromAny(interp, objPtr) * None. * * Side effects: - * The object's string may be set by converting its Unicode - * represention to UTF format. + * The object's string may be set by converting its Unicode represention + * to UTF format. * *---------------------------------------------------------------------- */ @@ -1858,12 +1889,10 @@ UpdateStringOfString(objPtr) stringPtr = GET_STRING(objPtr); if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) { - if (stringPtr->numChars <= 0) { - /* - * If there is no Unicode rep, or the string has 0 chars, - * then set the string rep to an empty string. + * If there is no Unicode rep, or the string has 0 chars, then set + * the string rep to an empty string. */ objPtr->bytes = tclEmptyStringRep; @@ -1874,15 +1903,15 @@ UpdateStringOfString(objPtr) unicode = stringPtr->unicode; /* - * Translate the Unicode string to UTF. "size" will hold the - * amount of space the UTF string needs. + * Translate the Unicode string to UTF. "size" will hold the amount of + * space the UTF string needs. */ size = 0; for (i = 0; i < stringPtr->numChars; i++) { size += Tcl_UniCharToUtf((int) unicode[i], dummy); } - + dst = (char *) ckalloc((unsigned) (size + 1)); objPtr->bytes = dst; objPtr->length = size; @@ -1901,14 +1930,14 @@ UpdateStringOfString(objPtr) * * FreeStringInternalRep -- * - * Deallocate the storage associated with a String data object's - * internal representation. + * Deallocate the storage associated with a String data object's internal + * representation. * * Results: * None. * * Side effects: - * Frees memory. + * Frees memory. * *---------------------------------------------------------------------- */ @@ -1919,3 +1948,11 @@ FreeStringInternalRep(objPtr) { ckfree((char *) GET_STRING(objPtr)); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index c03cc9e..f36d0d7 100755 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -2,24 +2,24 @@ * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed - * avoid lock contention). The basic strategy is to allocate memory in + * avoid lock contention). The basic strategy is to allocate memory in * fixed size blocks from block caches. * * The Initial Developer of the Original Code is America Online, Inc. * Portions created by AOL are Copyright (C) 1999 America Online, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadAlloc.c,v 1.16 2005/05/10 18:34:50 kennykb Exp $ + * RCS: @(#) $Id: tclThreadAlloc.c,v 1.17 2005/07/24 22:56:44 dkf Exp $ */ #include "tclInt.h" #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) /* - * If range checking is enabled, an additional byte will be allocated - * to store the magic number at the end of the requested memory. + * If range checking is enabled, an additional byte will be allocated to store + * the magic number at the end of the requested memory. */ #ifndef RCHECK @@ -31,33 +31,32 @@ #endif /* - * The following define the number of Tcl_Obj's to allocate/move - * at a time and the high water mark to prune a per-thread cache. - * On a 32 bit system, sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k. + * The following define the number of Tcl_Obj's to allocate/move at a time and + * the high water mark to prune a per-thread cache. On a 32 bit system, + * sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k. */ -#define NOBJALLOC 800 +#define NOBJALLOC 800 #define NOBJHIGH 1200 /* - * The following defines the number of buckets in the bucket - * cache and those block sizes from (1<<4) to (1<<(3+NBUCKETS)) + * The following defines the number of buckets in the bucket cache and those + * block sizes from (1<<4) to (1<<(3+NBUCKETS)) */ -#define NBUCKETS 11 -#define MAXALLOC 16284 +#define NBUCKETS 11 +#define MAXALLOC 16284 /* - * The following union stores accounting information for - * each block including two small magic numbers and - * a bucket number when in use or a next pointer when - * free. The original requested size (not including - * the Block overhead) is also maintained. + * The following union stores accounting information for each block including + * two small magic numbers and a bucket number when in use or a next pointer + * when free. The original requested size (not including the Block overhead) + * is also maintained. */ typedef struct Block { union { - struct Block *next; /* Next in free list. */ + struct Block *next; /* Next in free list. */ struct { unsigned char magic1; /* First magic number. */ unsigned char bucket; /* Bucket block allocated from. */ @@ -65,7 +64,7 @@ typedef struct Block { unsigned char magic2; /* Second magic number. */ } s; } u; - size_t reqSize; /* Requested allocation size. */ + size_t reqSize; /* Requested allocation size. */ } Block; #define nextBlock u.next #define sourceBucket u.s.bucket @@ -74,48 +73,47 @@ typedef struct Block { #define MAGIC 0xEF /* - * The following structure defines a bucket of blocks with - * various accounting and statistics information. + * The following structure defines a bucket of blocks with various accounting + * and statistics information. */ typedef struct Bucket { - Block *firstPtr; /* First block available */ - int numFree; /* Number of blocks available */ + Block *firstPtr; /* First block available */ + int numFree; /* Number of blocks available */ /* All fields below for accounting only */ - int numRemoves; /* Number of removes from bucket */ - int numInserts; /* Number of inserts into bucket */ - int numWaits; /* Number of waits to acquire a lock */ - int numLocks; /* Number of locks acquired */ - int totalAssigned; /* Total space assigned to bucket */ + int numRemoves; /* Number of removes from bucket */ + int numInserts; /* Number of inserts into bucket */ + int numWaits; /* Number of waits to acquire a lock */ + int numLocks; /* Number of locks acquired */ + int totalAssigned; /* Total space assigned to bucket */ } Bucket; /* - * The following structure defines a cache of buckets and objs, of - * which there will be (at most) one per thread. + * The following structure defines a cache of buckets and objs, of which there + * will be (at most) one per thread. */ typedef struct Cache { - struct Cache *nextPtr; /* Linked list of cache entries */ - Tcl_ThreadId owner; /* Which thread's cache is this? */ - Tcl_Obj *firstObjPtr; /* List of free objects for thread */ - int numObjects; /* Number of objects for thread */ - int totalAssigned; /* Total space assigned to thread */ - Bucket buckets[NBUCKETS]; /* The buckets for this thread */ + struct Cache *nextPtr; /* Linked list of cache entries */ + Tcl_ThreadId owner; /* Which thread's cache is this? */ + Tcl_Obj *firstObjPtr; /* List of free objects for thread */ + int numObjects; /* Number of objects for thread */ + int totalAssigned; /* Total space assigned to thread */ + Bucket buckets[NBUCKETS]; /* The buckets for this thread */ } Cache; /* - * The following array specifies various per-bucket limits and locks. - * The values are statically initialized to avoid calculating them - * repeatedly. + * The following array specifies various per-bucket limits and locks. The + * values are statically initialized to avoid calculating them repeatedly. */ static struct { - size_t blockSize; /* Bucket blocksize. */ - int maxBlocks; /* Max blocks before move to share. */ - int numMove; /* Num blocks to move to share. */ - Tcl_Mutex *lockPtr; /* Share bucket lock. */ + size_t blockSize; /* Bucket blocksize. */ + int maxBlocks; /* Max blocks before move to share. */ + int numMove; /* Num blocks to move to share. */ + Tcl_Mutex *lockPtr; /* Share bucket lock. */ } bucketInfo[NBUCKETS] = { { 16, 1024, 512, NULL}, { 32, 512, 256, NULL}, @@ -146,8 +144,7 @@ static void MoveObjs _ANSI_ARGS_((Cache *fromPtr, Cache *toPtr, int numMove)); /* - * Local variables defined in this file and initialized at - * startup. + * Local variables defined in this file and initialized at startup. */ static Tcl_Mutex *listLockPtr; @@ -306,10 +303,9 @@ TclpAlloc(reqSize) } /* - * Increment the requested size to include room for - * the Block structure. Call malloc() directly if the - * required amount is greater than the largest block, - * otherwise pop the smallest block large enough, + * Increment the requested size to include room for the Block structure. + * Call malloc() directly if the required amount is greater than the + * largest block, otherwise pop the smallest block large enough, * allocating more blocks if necessary. */ @@ -377,10 +373,9 @@ TclpFree(ptr) } /* - * Get the block back from the user pointer and call system free - * directly for large blocks. Otherwise, push the block back on - * the bucket and move blocks to the shared cache if there are now - * too many free. + * Get the block back from the user pointer and call system free directly + * for large blocks. Otherwise, push the block back on the bucket and move + * blocks to the shared cache if there are now too many free. */ blockPtr = Ptr2Block(ptr); @@ -390,11 +385,13 @@ TclpFree(ptr) free(blockPtr); return; } + cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize; blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; cachePtr->buckets[bucket].firstPtr = blockPtr; ++cachePtr->buckets[bucket].numFree; ++cachePtr->buckets[bucket].numInserts; + if (cachePtr != sharedPtr && cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) { PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove); @@ -437,10 +434,9 @@ TclpRealloc(ptr, reqSize) } /* - * If the block is not a system block and fits in place, - * simply return the existing pointer. Otherwise, if the block - * is a system block and the new size would also require a system - * block, call realloc() directly. + * If the block is not a system block and fits in place, simply return the + * existing pointer. Otherwise, if the block is a system block and the new + * size would also require a system block, call realloc() directly. */ blockPtr = Ptr2Block(ptr); @@ -496,8 +492,8 @@ TclpRealloc(ptr, reqSize) * Pointer to uninitialized Tcl_Obj. * * Side effects: - * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's - * if list is empty. + * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if + * list is empty. * *---------------------------------------------------------------------- */ @@ -506,20 +502,20 @@ Tcl_Obj * TclThreadAllocObj(void) { register Cache *cachePtr = TclpGetAllocCache(); - register int numMove; register Tcl_Obj *objPtr; - Tcl_Obj *newObjsPtr; if (cachePtr == NULL) { cachePtr = GetCache(); } /* - * Get this thread's obj list structure and move - * or allocate new objs if necessary. + * Get this thread's obj list structure and move or allocate new objs if + * necessary. */ if (cachePtr->numObjects == 0) { + register int numMove; + Tcl_MutexLock(objLockPtr); numMove = sharedPtr->numObjects; if (numMove > 0) { @@ -530,6 +526,8 @@ TclThreadAllocObj(void) } Tcl_MutexUnlock(objLockPtr); if (cachePtr->numObjects == 0) { + Tcl_Obj *newObjsPtr; + cachePtr->numObjects = numMove = NOBJALLOC; newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); if (newObjsPtr == NULL) { @@ -564,8 +562,7 @@ TclThreadAllocObj(void) * None. * * Side effects: - * May move free Tcl_Obj's to shared list upon hitting high - * water mark. + * May move free Tcl_Obj's to shared list upon hitting high water mark. * *---------------------------------------------------------------------- */ @@ -589,8 +586,8 @@ TclThreadFreeObj(objPtr) ++cachePtr->numObjects; /* - * If the number of free objects has exceeded the high - * water mark, move some blocks to the shared list. + * If the number of free objects has exceeded the high water mark, move + * some blocks to the shared list. */ if (cachePtr->numObjects > NOBJHIGH) { @@ -679,9 +676,8 @@ MoveObjs(fromPtr, toPtr, numMove) fromPtr->numObjects -= numMove; /* - * Find the last object to be moved; set the next one - * (the first one not to be moved) as the first object - * in the 'from' cache. + * Find the last object to be moved; set the next one (the first one not + * to be moved) as the first object in the 'from' cache. */ while (--numMove) { @@ -690,8 +686,8 @@ MoveObjs(fromPtr, toPtr, numMove) fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; /* - * Move all objects as a block - they are already linked to - * each other, we just have to update the first and last. + * Move all objects as a block - they are already linked to each other, we + * just have to update the first and last. */ objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; @@ -764,8 +760,8 @@ Ptr2Block(ptr) * None. * * Side effects: - * Lock activity and contention are monitored globally and on - * a per-cache basis. + * Lock activity and contention are monitored globally and on a per-cache + * basis. * *---------------------------------------------------------------------- */ @@ -821,8 +817,8 @@ PutBlocks(cachePtr, bucket, numMove) register int n = numMove; /* - * Before acquiring the lock, walk the block list to find - * the last block to be moved. + * Before acquiring the lock, walk the block list to find the last block + * to be moved. */ firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; @@ -833,8 +829,8 @@ PutBlocks(cachePtr, bucket, numMove) cachePtr->buckets[bucket].numFree -= numMove; /* - * Aquire the lock and place the list of blocks at the front - * of the shared cache bucket. + * Aquire the lock and place the list of blocks at the front of the shared + * cache bucket. */ LockBucket(cachePtr, bucket); @@ -867,13 +863,12 @@ GetBlocks(cachePtr, bucket) { register Block *blockPtr; register int n; - register size_t size; /* - * First, atttempt to move blocks from the shared cache. Note - * the potentially dirty read of numFree before acquiring the lock - * which is a slight performance enhancement. The value is - * verified after the lock is actually acquired. + * First, atttempt to move blocks from the shared cache. Note the + * potentially dirty read of numFree before acquiring the lock which is a + * slight performance enhancement. The value is verified after the lock is + * actually acquired. */ if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) { @@ -881,8 +876,8 @@ GetBlocks(cachePtr, bucket) if (sharedPtr->buckets[bucket].numFree > 0) { /* - * Either move the entire list or walk the list to find - * the last block to move. + * Either move the entire list or walk the list to find the last + * block to move. */ n = bucketInfo[bucket].numMove; @@ -909,10 +904,11 @@ GetBlocks(cachePtr, bucket) } if (cachePtr->buckets[bucket].numFree == 0) { + register size_t size; /* - * If no blocks could be moved from shared, first look for a - * larger block in this cache to split up. + * If no blocks could be moved from shared, first look for a larger + * block in this cache to split up. */ blockPtr = NULL; @@ -962,8 +958,8 @@ GetBlocks(cachePtr, bucket) * * TclFinalizeThreadAlloc -- * - * This procedure is used to destroy all private resources used in - * this file. + * This procedure is used to destroy all private resources used in this + * file. * * Results: * None. @@ -979,7 +975,7 @@ TclFinalizeThreadAlloc() { int i; for (i = 0; i < NBUCKETS; ++i) { - TclpFreeAllocMutex(bucketInfo[i].lockPtr); + TclpFreeAllocMutex(bucketInfo[i].lockPtr); bucketInfo[i].lockPtr = NULL; } @@ -993,14 +989,13 @@ TclFinalizeThreadAlloc() } #else - /* *---------------------------------------------------------------------- * * TclFinalizeThreadAlloc -- * - * This procedure is used to destroy all private resources used in - * this file. + * This procedure is used to destroy all private resources used in this + * file. * * Results: * None. @@ -1016,5 +1011,12 @@ TclFinalizeThreadAlloc() { Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use."); } - #endif /* TCL_THREADS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 85e8c0c..ce07825 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -1,4 +1,4 @@ -/* +/* * tclTimer.c -- * * This file provides timer event management facilities for Tcl, @@ -6,76 +6,75 @@ * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTimer.c,v 1.16 2005/06/17 14:26:15 dkf Exp $ + * RCS: @(#) $Id: tclTimer.c,v 1.17 2005/07/24 22:56:44 dkf Exp $ */ #include "tclInt.h" /* * For each timer callback that's pending there is one record of the following - * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained + * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained * together in a list sorted by time (earliest event first). */ typedef struct TimerHandler { - Tcl_Time time; /* When timer is to fire. */ - Tcl_TimerProc *proc; /* Procedure to call. */ - ClientData clientData; /* Argument to pass to proc. */ - Tcl_TimerToken token; /* Identifies handler so it can be - * deleted. */ - struct TimerHandler *nextPtr; /* Next event in queue, or NULL for - * end of queue. */ + Tcl_Time time; /* When timer is to fire. */ + Tcl_TimerProc *proc; /* Function to call. */ + ClientData clientData; /* Argument to pass to proc. */ + Tcl_TimerToken token; /* Identifies handler so it can be deleted. */ + struct TimerHandler *nextPtr; + /* Next event in queue, or NULL for end of + * queue. */ } TimerHandler; /* - * The data structure below is used by the "after" command to remember - * the command to be executed later. All of the pending "after" commands - * for an interpreter are linked together in a list. + * The data structure below is used by the "after" command to remember the + * command to be executed later. All of the pending "after" commands for an + * interpreter are linked together in a list. */ typedef struct AfterInfo { struct AfterAssocData *assocPtr; - /* Pointer to the "tclAfter" assocData for - * the interp in which command will be + /* Pointer to the "tclAfter" assocData for the + * interp in which command will be * executed. */ Tcl_Obj *commandPtr; /* Command to execute. */ - int id; /* Integer identifier for command; used to + int id; /* Integer identifier for command; used to * cancel it. */ - Tcl_TimerToken token; /* Used to cancel the "after" command. NULL - * means that the command is run as an - * idle handler rather than as a timer - * handler. NULL means this is an "after - * idle" handler rather than a - * timer handler. */ + Tcl_TimerToken token; /* Used to cancel the "after" command. NULL + * means that the command is run as an idle + * handler rather than as a timer handler. + * NULL means this is an "after idle" handler + * rather than a timer handler. */ struct AfterInfo *nextPtr; /* Next in list of all "after" commands for * this interpreter. */ } AfterInfo; /* - * One of the following structures is associated with each interpreter - * for which an "after" command has ever been invoked. A pointer to - * this structure is stored in the AssocData for the "tclAfter" key. + * One of the following structures is associated with each interpreter for + * which an "after" command has ever been invoked. A pointer to this structure + * is stored in the AssocData for the "tclAfter" key. */ typedef struct AfterAssocData { Tcl_Interp *interp; /* The interpreter for which this data is * registered. */ - AfterInfo *firstAfterPtr; /* First in list of all "after" commands - * still pending for this interpreter, or - * NULL if none. */ + AfterInfo *firstAfterPtr; /* First in list of all "after" commands still + * pending for this interpreter, or NULL if + * none. */ } AfterAssocData; /* - * There is one of the following structures for each of the - * handlers declared in a call to Tcl_DoWhenIdle. All of the - * currently-active handlers are linked together into a list. + * There is one of the following structures for each of the handlers declared + * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are + * linked together into a list. */ typedef struct IdleHandler { - Tcl_IdleProc (*proc); /* Procedure to call. */ + Tcl_IdleProc (*proc); /* Function to call. */ ClientData clientData; /* Value to pass to proc. */ int generation; /* Used to distinguish older handlers from * recently-created ones. */ @@ -83,37 +82,55 @@ typedef struct IdleHandler { } IdleHandler; /* - * The timer and idle queues are per-thread because they are associated - * with the notifier, which is also per-thread. + * The timer and idle queues are per-thread because they are associated with + * the notifier, which is also per-thread. * - * All static variables used in this file are collected into a single - * instance of the following structure. For multi-threaded implementations, - * there is one instance of this structure for each thread. + * All static variables used in this file are collected into a single instance + * of the following structure. For multi-threaded implementations, there is + * one instance of this structure for each thread. * - * Notice that different structures with the same name appear in other - * files. The structure defined below is used in this file only. + * Notice that different structures with the same name appear in other files. + * The structure defined below is used in this file only. */ typedef struct ThreadSpecificData { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ - int lastTimerId; /* Timer identifier of most recently - * created timer. */ + int lastTimerId; /* Timer identifier of most recently created + * timer. */ int timerPending; /* 1 if a timer event is in the queue. */ IdleHandler *idleList; /* First in list of all idle handlers. */ IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */ - int idleGeneration; /* Used to fill in the "generation" fields - * of IdleHandler structures. Increments - * each time Tcl_DoOneEvent starts calling - * idle handlers, so that all old handlers - * can be called without calling any of the - * new ones created by old ones. */ + int idleGeneration; /* Used to fill in the "generation" fields of + * IdleHandler structures. Increments each + * time Tcl_DoOneEvent starts calling idle + * handlers, so that all old handlers can be + * called without calling any of the new ones + * created by old ones. */ int afterId; /* For unique identifiers of after events. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * Prototypes for procedures referenced only in this file: + * Helper macros for working with times. TCL_TIME_BEFORE encodes how to write + * the ordering relation on (normalized) times, and TCL_TIME_DIFF_MS computes + * the number of milliseconds difference between two times. Both macros use + * both of their arguments multiple times, so make sure they are cheap and + * side-effect free. The "prototypes" for these macros are: + * + * static int TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2); + * static long TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2); + */ + +#define TCL_TIME_BEFORE(t1, t2) \ + (((t1).sec<(t2).sec) || ((t1).sec==(t2).sec && (t1).usec<(t2).usec)) + +#define TCL_TIME_DIFF_MS(t1, t2) \ + (1000*((long)(t1).sec - (long)(t2).sec) + \ + ((long)(t1).usec - (long)(t2).usec)/1000) + +/* + * Prototypes for functions referenced only in this file: */ static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData, @@ -151,8 +168,8 @@ static void TimerSetupProc _ANSI_ARGS_((ClientData clientData, static ThreadSpecificData * InitTimer() { - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); @@ -167,8 +184,8 @@ InitTimer() * * TimerExitProc -- * - * This function is call at exit or unload time to remove the - * timer and idle event sources. + * This function is call at exit or unload time to remove the timer and + * idle event sources. * * Results: * None. @@ -183,12 +200,13 @@ static void TimerExitProc(clientData) ClientData clientData; /* Not used. */ { - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); if (tsdPtr != NULL) { register TimerHandler *timerHandlerPtr; + timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; while (timerHandlerPtr != NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; @@ -203,25 +221,24 @@ TimerExitProc(clientData) * * Tcl_CreateTimerHandler -- * - * Arrange for a given procedure to be invoked at a particular - * time in the future. + * Arrange for a given function to be invoked at a particular time in the + * future. * * Results: - * The return value is a token for the timer event, which - * may be used to delete the event before it fires. + * The return value is a token for the timer event, which may be used to + * delete the event before it fires. * * Side effects: - * When milliseconds have elapsed, proc will be invoked - * exactly once. + * When milliseconds have elapsed, proc will be invoked exactly once. * *-------------------------------------------------------------- */ Tcl_TimerToken Tcl_CreateTimerHandler(milliseconds, proc, clientData) - int milliseconds; /* How many milliseconds to wait - * before invoking proc. */ - Tcl_TimerProc *proc; /* Procedure to invoke. */ + int milliseconds; /* How many milliseconds to wait before + * invoking proc. */ + Tcl_TimerProc *proc; /* Function to invoke. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { Tcl_Time time; @@ -245,12 +262,12 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData) * * TclCreateAbsoluteTimerHandler -- * - * Arrange for a given procedure to be invoked at a particular - * time in the future. + * Arrange for a given function to be invoked at a particular time in the + * future. * * Results: - * The return value is a token for the timer event, which - * may be used to delete the event before it fires. + * The return value is a token for the timer event, which may be used to + * delete the event before it fires. * * Side effects: * When the time in timePtr has been reached, proc will be invoked @@ -288,9 +305,7 @@ TclCreateAbsoluteTimerHandler(timePtr, proc, clientData) for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { - if ((tPtr2->time.sec > timerHandlerPtr->time.sec) - || ((tPtr2->time.sec == timerHandlerPtr->time.sec) - && (tPtr2->time.usec > timerHandlerPtr->time.usec))) { + if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) { break; } } @@ -317,10 +332,9 @@ TclCreateAbsoluteTimerHandler(timePtr, proc, clientData) * None. * * Side effects: - * Destroy the timer callback identified by TimerToken, - * so that its associated procedure will not be called. - * If the callback has already fired, or if the given - * token doesn't exist, then nothing happens. + * Destroy the timer callback identified by TimerToken, so that its + * associated function will not be called. If the callback has already + * fired, or if the given token doesn't exist, then nothing happens. * *-------------------------------------------------------------- */ @@ -355,9 +369,9 @@ Tcl_DeleteTimerHandler(token) * * TimerSetupProc -- * - * This function is called by Tcl_DoOneEvent to setup the timer - * event source for before blocking. This routine checks both the - * idle and after timer lists. + * This function is called by Tcl_DoOneEvent to setup the timer event + * source for before blocking. This routine checks both the idle and + * after timer lists. * * Results: * None. @@ -405,7 +419,7 @@ TimerSetupProc(data, flags) } else { return; } - + Tcl_SetMaxBlockTime(&blockTime); } @@ -414,9 +428,9 @@ TimerSetupProc(data, flags) * * TimerCheckProc -- * - * This function is called by Tcl_DoOneEvent to check the timer - * event source for events. This routine checks both the - * idle and after timer lists. + * This function is called by Tcl_DoOneEvent to check the timer event + * source for events. This routine checks both the idle and after timer + * lists. * * Results: * None. @@ -473,19 +487,18 @@ TimerCheckProc(data, flags) * * TimerHandlerEventProc -- * - * This procedure is called by Tcl_ServiceEvent when a timer event - * reaches the front of the event queue. This procedure handles - * the event by invoking the callbacks for all timers that are - * ready. + * This function is called by Tcl_ServiceEvent when a timer event reaches + * the front of the event queue. This function handles the event by + * invoking the callbacks for all timers that are ready. * * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_TIMER_EVENTS flag bit isn't set. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_TIMER_EVENTS flag bit isn't set. * * Side effects: - * Whatever the timer handler callback procedures do. + * Whatever the timer handler callback functions do. * *---------------------------------------------------------------------- */ @@ -493,8 +506,8 @@ TimerCheckProc(data, flags) static int TimerHandlerEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ + int flags; /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { TimerHandler *timerHandlerPtr, **nextPtrPtr; Tcl_Time time; @@ -502,9 +515,9 @@ TimerHandlerEventProc(evPtr, flags) ThreadSpecificData *tsdPtr = InitTimer(); /* - * Do nothing if timers aren't enabled. This leaves the event on the - * queue, so we will get to it as soon as ServiceEvents() is called - * with timers enabled. + * Do nothing if timers aren't enabled. This leaves the event on the + * queue, so we will get to it as soon as ServiceEvents() is called with + * timers enabled. */ if (!(flags & TCL_TIMER_EVENTS)) { @@ -512,30 +525,28 @@ TimerHandlerEventProc(evPtr, flags) } /* - * The code below is trickier than it may look, for the following - * reasons: + * The code below is trickier than it may look, for the following reasons: * - * 1. New handlers can get added to the list while the current - * one is being processed. If new ones get added, we don't - * want to process them during this pass through the list to avoid - * starving other event sources. This is implemented using the - * token number in the handler: new handlers will have a - * newer token than any of the ones currently on the list. - * 2. The handler can call Tcl_DoOneEvent, so we have to remove - * the handler from the list before calling it. Otherwise an - * infinite loop could result. - * 3. Tcl_DeleteTimerHandler can be called to remove an element from - * the list while a handler is executing, so the list could - * change structure during the call. - * 4. Because we only fetch the current time before entering the loop, - * the only way a new timer will even be considered runnable is if - * its expiration time is within the same millisecond as the - * current time. This is fairly likely on Windows, since it has - * a course granularity clock. Since timers are placed - * on the queue in time order with the most recently created - * handler appearing after earlier ones with the same expiration - * time, we don't have to worry about newer generation timers - * appearing before later ones. + * 1. New handlers can get added to the list while the current one is + * being processed. If new ones get added, we don't want to process + * them during this pass through the list to avoid starving other event + * sources. This is implemented using the token number in the handler: + * new handlers will have a newer token than any of the ones currently + * on the list. + * 2. The handler can call Tcl_DoOneEvent, so we have to remove the + * handler from the list before calling it. Otherwise an infinite loop + * could result. + * 3. Tcl_DeleteTimerHandler can be called to remove an element from the + * list while a handler is executing, so the list could change + * structure during the call. + * 4. Because we only fetch the current time before entering the loop, the + * only way a new timer will even be considered runnable is if its + * expiration time is within the same millisecond as the current time. + * This is fairly likely on Windows, since it has a course granularity + * clock. Since timers are placed on the queue in time order with the + * most recently created handler appearing after earlier ones with the + * same expiration time, we don't have to worry about newer generation + * timers appearing before later ones. */ tsdPtr->timerPending = 0; @@ -547,10 +558,8 @@ TimerHandlerEventProc(evPtr, flags) if (timerHandlerPtr == NULL) { break; } - - if ((timerHandlerPtr->time.sec > time.sec) - || ((timerHandlerPtr->time.sec == time.sec) - && (timerHandlerPtr->time.usec > time.usec))) { + + if (TCL_TIME_BEFORE(time, timerHandlerPtr->time)) { break; } @@ -563,8 +572,8 @@ TimerHandlerEventProc(evPtr, flags) } /* - * Remove the handler from the queue before invoking it, - * to avoid potential reentrancy problems. + * Remove the handler from the queue before invoking it, to avoid + * potential reentrancy problems. */ (*nextPtrPtr) = timerHandlerPtr->nextPtr; @@ -580,23 +589,23 @@ TimerHandlerEventProc(evPtr, flags) * * Tcl_DoWhenIdle -- * - * Arrange for proc to be invoked the next time the system is - * idle (i.e., just before the next time that Tcl_DoOneEvent - * would have to wait for something to happen). + * Arrange for proc to be invoked the next time the system is idle (i.e., + * just before the next time that Tcl_DoOneEvent would have to wait for + * something to happen). * * Results: * None. * * Side effects: - * Proc will eventually be called, with clientData as argument. - * See the manual entry for details. + * Proc will eventually be called, with clientData as argument. See the + * manual entry for details. * *-------------------------------------------------------------- */ void Tcl_DoWhenIdle(proc, clientData) - Tcl_IdleProc *proc; /* Procedure to invoke. */ + Tcl_IdleProc *proc; /* Function to invoke. */ ClientData clientData; /* Arbitrary value to pass to proc. */ { register IdleHandler *idlePtr; @@ -625,22 +634,22 @@ Tcl_DoWhenIdle(proc, clientData) * * Tcl_CancelIdleCall -- * - * If there are any when-idle calls requested to a given procedure - * with given clientData, cancel all of them. + * If there are any when-idle calls requested to a given function with + * given clientData, cancel all of them. * * Results: * None. * * Side effects: - * If the proc/clientData combination were on the when-idle list, - * they are removed so that they will never be called. + * If the proc/clientData combination were on the when-idle list, they + * are removed so that they will never be called. * *---------------------------------------------------------------------- */ void Tcl_CancelIdleCall(proc, clientData) - Tcl_IdleProc *proc; /* Procedure that was previously registered. */ + Tcl_IdleProc *proc; /* Function that was previously registered. */ ClientData clientData; /* Arbitrary value to pass to proc. */ { register IdleHandler *idlePtr, *prevPtr; @@ -672,14 +681,13 @@ Tcl_CancelIdleCall(proc, clientData) * * TclServiceIdle -- * - * This procedure is invoked by the notifier when it becomes - * idle. It will invoke all idle handlers that are present at - * the time the call is invoked, but not those added during idle - * processing. + * This function is invoked by the notifier when it becomes idle. It will + * invoke all idle handlers that are present at the time the call is + * invoked, but not those added during idle processing. * * Results: - * The return value is 1 if TclServiceIdle found something to - * do, otherwise return value is 0. + * The return value is 1 if TclServiceIdle found something to do, + * otherwise return value is 0. * * Side effects: * Invokes all pending idle handlers. @@ -703,22 +711,20 @@ TclServiceIdle() tsdPtr->idleGeneration++; /* - * The code below is trickier than it may look, for the following - * reasons: + * The code below is trickier than it may look, for the following reasons: * - * 1. New handlers can get added to the list while the current - * one is being processed. If new ones get added, we don't - * want to process them during this pass through the list (want - * to check for other work to do first). This is implemented - * using the generation number in the handler: new handlers - * will have a different generation than any of the ones currently - * on the list. - * 2. The handler can call Tcl_DoOneEvent, so we have to remove - * the handler from the list before calling it. Otherwise an - * infinite loop could result. - * 3. Tcl_CancelIdleCall can be called to remove an element from - * the list while a handler is executing, so the list could - * change structure during the call. + * 1. New handlers can get added to the list while the current one is + * being processed. If new ones get added, we don't want to process + * them during this pass through the list (want to check for other work + * to do first). This is implemented using the generation number in the + * handler: new handlers will have a different generation than any of + * the ones currently on the list. + * 2. The handler can call Tcl_DoOneEvent, so we have to remove the + * handler from the list before calling it. Otherwise an infinite loop + * could result. + * 3. Tcl_CancelIdleCall can be called to remove an element from the list + * while a handler is executing, so the list could change structure + * during the call. */ for (idlePtr = tsdPtr->idleList; @@ -745,8 +751,8 @@ TclServiceIdle() * * Tcl_AfterObjCmd -- * - * This procedure is invoked to process the "after" Tcl command. - * See the user documentation for details on what it does. + * This function is invoked to process the "after" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -784,11 +790,11 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) } /* - * Create the "after" information associated for this interpreter, - * if it doesn't already exist. + * Create the "after" information associated for this interpreter, if it + * doesn't already exist. */ - assocPtr = Tcl_GetAssocData( interp, "tclAfter", NULL ); + assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL); if (assocPtr == NULL) { assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; @@ -810,7 +816,7 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) { return TCL_ERROR; } -processInteger: + processInteger: if (ms < 0) { ms = 0; } @@ -825,15 +831,17 @@ processInteger: afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); } Tcl_IncrRefCount(afterPtr->commandPtr); + /* - * The variable below is used to generate unique identifiers for - * after commands. This id can wrap around, which can potentially - * cause problems. However, there are not likely to be problems - * in practice, because after commands can only be requested to - * about a month in the future, and wrap-around is unlikely to - * occur in less than about 1-10 years. Thus it's unlikely that - * any old ids will still be around when wrap-around occurs. + * The variable below is used to generate unique identifiers for after + * commands. This id can wrap around, which can potentially cause + * problems. However, there are not likely to be problems in practice, + * because after commands can only be requested to about a month in + * the future, and wrap-around is unlikely to occur in less than about + * 1-10 years. Thus it's unlikely that any old ids will still be + * around when wrap-around occurs. */ + afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, @@ -846,113 +854,113 @@ processInteger: } /* - * If it's not a number it must be a subcommand. + * If it's not a number it must be a subcommand. Note that we're using a + * custom error message here, so we do not pass an interpreter to T_GIFO. */ - if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument", - 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument", 0, + &index) != TCL_OK) { Tcl_AppendResult(interp, "bad argument \"", argString, "\": must be cancel, idle, info, or a number", (char *) NULL); return TCL_ERROR; } switch ((enum afterSubCmds) index) { - case AFTER_CANCEL: { - Tcl_Obj *commandPtr; - char *command, *tempCommand; - int tempLength; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "id|command"); - return TCL_ERROR; + case AFTER_CANCEL: { + Tcl_Obj *commandPtr; + char *command, *tempCommand; + int tempLength; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "id|command"); + return TCL_ERROR; + } + if (objc == 3) { + commandPtr = objv[2]; + } else { + commandPtr = Tcl_ConcatObj(objc-2, objv+2);; + } + command = Tcl_GetStringFromObj(commandPtr, &length); + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, + &tempLength); + if ((length == tempLength) + && (memcmp((void*) command, (void*) tempCommand, + (unsigned) length) == 0)) { + break; } - if (objc == 3) { - commandPtr = objv[2]; + } + if (afterPtr == NULL) { + afterPtr = GetAfterEvent(assocPtr, commandPtr); + } + if (objc != 3) { + Tcl_DecrRefCount(commandPtr); + } + if (afterPtr != NULL) { + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); } else { - commandPtr = Tcl_ConcatObj(objc-2, objv+2);; + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); } - command = Tcl_GetStringFromObj(commandPtr, &length); - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + FreeAfterPtr(afterPtr); + } + break; + } + case AFTER_IDLE: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); + return TCL_ERROR; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (objc == 3) { + afterPtr->commandPtr = objv[2]; + } else { + afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); + } + Tcl_IncrRefCount(afterPtr->commandPtr); + afterPtr->id = tsdPtr->afterId; + tsdPtr->afterId += 1; + afterPtr->token = NULL; + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); + sprintf(buf, "after#%d", afterPtr->id); + Tcl_AppendResult(interp, buf, (char *) NULL); + break; + case AFTER_INFO: { + Tcl_Obj *resultListPtr; + + if (objc == 2) { + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { - tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, - &tempLength); - if ((length == tempLength) - && (memcmp((void*) command, (void*) tempCommand, - (unsigned) length) == 0)) { - break; + if (assocPtr->interp == interp) { + sprintf(buf, "after#%d", afterPtr->id); + Tcl_AppendElement(interp, buf); } } - if (afterPtr == NULL) { - afterPtr = GetAfterEvent(assocPtr, commandPtr); - } - if (objc != 3) { - Tcl_DecrRefCount(commandPtr); - } - if (afterPtr != NULL) { - if (afterPtr->token != NULL) { - Tcl_DeleteTimerHandler(afterPtr->token); - } else { - Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); - } - FreeAfterPtr(afterPtr); - } - break; + return TCL_OK; } - case AFTER_IDLE: - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); - return TCL_ERROR; - } - afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); - afterPtr->assocPtr = assocPtr; - if (objc == 3) { - afterPtr->commandPtr = objv[2]; - } else { - afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); - } - Tcl_IncrRefCount(afterPtr->commandPtr); - afterPtr->id = tsdPtr->afterId; - tsdPtr->afterId += 1; - afterPtr->token = NULL; - afterPtr->nextPtr = assocPtr->firstAfterPtr; - assocPtr->firstAfterPtr = afterPtr; - Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); - sprintf(buf, "after#%d", afterPtr->id); - Tcl_AppendResult(interp, buf, (char *) NULL); - break; - case AFTER_INFO: { - Tcl_Obj *resultListPtr; - - if (objc == 2) { - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (assocPtr->interp == interp) { - sprintf(buf, "after#%d", afterPtr->id); - Tcl_AppendElement(interp, buf); - } - } - return TCL_OK; - } - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?id?"); - return TCL_ERROR; - } - afterPtr = GetAfterEvent(assocPtr, objv[2]); - if (afterPtr == NULL) { - Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]), - "\" doesn't exist", (char *) NULL); - return TCL_ERROR; - } - resultListPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( - (afterPtr->token == NULL) ? "idle" : "timer", -1)); - Tcl_SetObjResult(interp, resultListPtr); - break; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?id?"); + return TCL_ERROR; } - default: { - Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); + afterPtr = GetAfterEvent(assocPtr, objv[2]); + if (afterPtr == NULL) { + Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]), + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; } + resultListPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + (afterPtr->token == NULL) ? "idle" : "timer", -1)); + Tcl_SetObjResult(interp, resultListPtr); + break; + } + default: + Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); } return TCL_OK; } @@ -962,13 +970,12 @@ processInteger: * * AfterDelay -- * - * Implements the blocking delay behaviour of [after $time]. - * Tricky because it has to take into account any time limit that - * has been set. + * Implements the blocking delay behaviour of [after $time]. Tricky + * because it has to take into account any time limit that has been set. * * Results: - * Standard Tcl result code (with error set if an error occurred - * due to a time limit being exceeded). + * Standard Tcl result code (with error set if an error occurred due to a + * time limit being exceeded). * * Side effects: * May adjust the time limit granularity marker. @@ -982,11 +989,6 @@ AfterDelay(interp, ms) int ms; { Interp *iPtr = (Interp *) interp; -#define TCL_TIME_BEFORE(t1,t2) \ - (((t1).sec<(t2).sec)||((t1).sec==(t2).sec&&(t1).usec<(t2).usec)) -#define TCL_TIME_DIFF_MS(t1,t2) \ - (1000*((long)(t1).sec - (long)(t2).sec) + \ - ((long)(t1).usec - (long)(t2).usec)/1000) if (iPtr->limit.timeEvent != NULL) { Tcl_Time endTime, now; @@ -1020,8 +1022,6 @@ AfterDelay(interp, ms) } else { Tcl_Sleep(ms); } -#undef TCL_TIME_BEFORE -#undef TCL_TIME_DIFF_MS return TCL_OK; } @@ -1030,13 +1030,13 @@ AfterDelay(interp, ms) * * GetAfterEvent -- * - * This procedure parses an "after" id such as "after#4" and - * returns a pointer to the AfterInfo structure. + * This function parses an "after" id such as "after#4" and returns a + * pointer to the AfterInfo structure. * * Results: - * The return value is either a pointer to an AfterInfo structure, - * if one is found that corresponds to "cmdString" and is for interp, - * or NULL if no corresponding after event can be found. + * The return value is either a pointer to an AfterInfo structure, if one + * is found that corresponds to "cmdString" and is for interp, or NULL if + * no corresponding after event can be found. * * Side effects: * None. @@ -1050,8 +1050,8 @@ GetAfterEvent(assocPtr, commandPtr) * this interpreter. */ Tcl_Obj *commandPtr; { - char *cmdString; /* Textual identifier for after event, such - * as "after#6". */ + char *cmdString; /* Textual identifier for after event, such as + * "after#6". */ AfterInfo *afterPtr; int id; char *end; @@ -1079,17 +1079,16 @@ GetAfterEvent(assocPtr, commandPtr) * * AfterProc -- * - * Timer callback to execute commands registered with the - * "after" command. + * Timer callback to execute commands registered with the "after" + * command. * * Results: * None. * * Side effects: - * Executes whatever command was specified. If the command - * returns an error, then the command "bgerror" is invoked - * to process the error; if bgerror fails then information - * about the error is output on stderr. + * Executes whatever command was specified. If the command returns an + * error, then the command "bgerror" is invoked to process the error; if + * bgerror fails then information about the error is output on stderr. * *---------------------------------------------------------------------- */ @@ -1107,9 +1106,9 @@ AfterProc(clientData) int numBytes; /* - * First remove the callback from our list of callbacks; otherwise - * someone could delete the callback while it's being executed, which - * could cause a core dump. + * First remove the callback from our list of callbacks; otherwise someone + * could delete the callback while it's being executed, which could cause + * a core dump. */ if (assocPtr->firstAfterPtr == afterPtr) { @@ -1135,7 +1134,7 @@ AfterProc(clientData) Tcl_BackgroundError(interp); } Tcl_Release((ClientData) interp); - + /* * Free the memory for the callback. */ @@ -1149,10 +1148,9 @@ AfterProc(clientData) * * FreeAfterPtr -- * - * This procedure removes an "after" command from the list of - * those that are pending and frees its resources. This procedure - * does *not* cancel the timer handler; if that's needed, the - * caller must do it. + * This function removes an "after" command from the list of those that + * are pending and frees its resources. This function does *not* cancel + * the timer handler; if that's needed, the caller must do it. * * Results: * None. @@ -1188,7 +1186,7 @@ FreeAfterPtr(afterPtr) * * AfterCleanupProc -- * - * This procedure is invoked whenever an interpreter is deleted + * This function is invoked whenever an interpreter is deleted * to cleanup the AssocData for "tclAfter". * * Results: @@ -1223,3 +1221,11 @@ AfterCleanupProc(clientData, interp) } ckfree((char *) assocPtr); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 248a38d..1031334 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1,17 +1,17 @@ -/* +/* * tclUtil.c -- * - * This file contains utility procedures that are used by many Tcl + * This file contains utility functions that are used by many Tcl * commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.61 2005/07/05 18:15:59 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.62 2005/07/24 22:56:44 dkf Exp $ */ #include "tclInt.h" @@ -45,27 +45,27 @@ static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL}; /* - * The following values are used in the flags returned by Tcl_ScanElement - * and used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and - * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value - * overlaps with any of the values below. + * The following values are used in the flags returned by Tcl_ScanElement and + * used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and + * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value overlaps + * with any of the values below. * * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in - * braces (e.g. it contains unmatched braces, - * or ends in a backslash character, or user - * just doesn't want braces); handle all - * special characters by adding backslashes. + * braces (e.g. it contains unmatched braces, or + * ends in a backslash character, or user just + * doesn't want braces); handle all special + * characters by adding backslashes. * USE_BRACES - 1 means the string contains a special * character that can be handled simply by * enclosing the entire argument in braces. - * BRACES_UNMATCHED - 1 means that braces aren't properly matched - * in the argument. - * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading - * hash character ('#') should *not* be quoted. - * This is appropriate when the caller can - * guarantee the element is not the first element - * of a list, so [eval] cannot mis-parse the - * element as a comment. + * BRACES_UNMATCHED - 1 means that braces aren't properly matched in + * the argument. + * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash + * character ('#') should *not* be quoted. This + * is appropriate when the caller can guarantee + * the element is not the first element of a + * list, so [eval] cannot mis-parse the element + * as a comment. */ #define USE_BRACES 2 @@ -73,43 +73,42 @@ static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL}; /* * The following values determine the precision used when converting - * floating-point values to strings. This information is linked to all - * of the tcl_precision variables in all interpreters via the procedure + * floating-point values to strings. This information is linked to all of the + * tcl_precision variables in all interpreters via the function * TclPrecTraceProc. */ -static int precision = 0; /* Precision of floating point conversions, - * in the range 0-17 inclusive. */ +static int precision = 0; /* Precision of floating point conversions, in + * the range 0-17 inclusive. */ TCL_DECLARE_MUTEX(precisionMutex) /* - * Prototypes for procedures defined later in this file. + * Prototypes for functions defined later in this file. */ static void ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr)); static void FreeProcessGlobalValue _ANSI_ARGS_(( ClientData clientData)); -static void FreeThreadHash _ANSI_ARGS_ ((ClientData clientData)); -static Tcl_HashTable * GetThreadHash _ANSI_ARGS_ ((Tcl_ThreadDataKey *keyPtr)); +static void FreeThreadHash _ANSI_ARGS_((ClientData clientData)); +static Tcl_HashTable * GetThreadHash _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr)); static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj* objPtr)); + Tcl_Obj* objPtr)); static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); /* - * The following is the Tcl object type definition for an object - * that represents a list index in the form, "end-offset". It is - * used as a performance optimization in TclGetIntForIndex. The - * internal rep is an integer, so no memory management is required - * for it. + * The following is the Tcl object type definition for an object that + * represents a list index in the form, "end-offset". It is used as a + * performance optimization in TclGetIntForIndex. The internal rep is an + * integer, so no memory management is required for it. */ Tcl_ObjType tclEndOffsetType = { "end-offset", /* name */ (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ + (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ UpdateStringOfEndOffset, /* updateStringProc */ - SetEndOffsetFromAny + SetEndOffsetFromAny }; @@ -118,28 +117,28 @@ Tcl_ObjType tclEndOffsetType = { * * TclFindElement -- * - * Given a pointer into a Tcl list, locate the first (or next) - * element in the list. + * Given a pointer into a Tcl list, locate the first (or next) element in + * the list. * * Results: - * The return value is normally TCL_OK, which means that the - * element was successfully located. If TCL_ERROR is returned - * it means that list didn't have proper list structure; - * the interp's result contains a more detailed error message. + * The return value is normally TCL_OK, which means that the element was + * successfully located. If TCL_ERROR is returned it means that list + * didn't have proper list structure; the interp's result contains a more + * detailed error message. * * If TCL_OK is returned, then *elementPtr will be set to point to the * first element of list, and *nextPtr will be set to point to the * character just after any white space following the last character - * that's part of the element. If this is the last argument in the - * list, then *nextPtr will point just after the last character in the - * list (i.e., at the character at list+listLength). If sizePtr is - * non-NULL, *sizePtr is filled in with the number of characters in the - * element. If the element is in braces, then *elementPtr will point - * to the character after the opening brace and *sizePtr will not - * include either of the braces. If there isn't an element in the list, - * *sizePtr will be zero, and both *elementPtr and *termPtr will point - * just after the last character in the list. Note: this procedure does - * NOT collapse backslash sequences. + * that's part of the element. If this is the last argument in the list, + * then *nextPtr will point just after the last character in the list + * (i.e., at the character at list+listLength). If sizePtr is non-NULL, + * *sizePtr is filled in with the number of characters in the element. If + * the element is in braces, then *elementPtr will point to the character + * after the opening brace and *sizePtr will not include either of the + * braces. If there isn't an element in the list, *sizePtr will be zero, + * and both *elementPtr and *termPtr will point just after the last + * character in the list. Note: this function does NOT collapse backslash + * sequences. * * Side effects: * None. @@ -149,10 +148,10 @@ Tcl_ObjType tclEndOffsetType = { int TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, - bracePtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, then no error message is left - * after errors. */ + bracePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ CONST char *list; /* Points to the first byte of a string * containing a Tcl list with zero or more * elements (possibly in braces). */ @@ -164,9 +163,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, * argument (next arg or end of list). */ int *sizePtr; /* If non-zero, fill in with size of * element. */ - int *bracePtr; /* If non-zero, fill in with non-zero/zero - * to indicate that arg was/wasn't - * in braces. */ + int *bracePtr; /* If non-zero, fill in with non-zero/zero to + * indicate that arg was/wasn't in braces. */ { CONST char *p = list; CONST char *elemStart; /* Points to first byte of first element. */ @@ -176,11 +174,11 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, int size = 0; /* lint. */ int numChars; CONST char *p2; - + /* - * Skim off leading white space and check for an opening brace or - * quote. We treat embedded NULLs in the list as bytes belonging to - * a list element. + * Skim off leading white space and check for an opening brace or quote. + * We treat embedded NULLs in the list as bytes belonging to a list + * element. */ limit = (list + listLength); @@ -210,123 +208,120 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, while (p < limit) { switch (*p) { - /* * Open brace: don't treat specially unless the element is in * braces. In this case, keep a nesting count. */ - case '{': - if (openBraces != 0) { - openBraces++; - } - break; + case '{': + if (openBraces != 0) { + openBraces++; + } + break; /* * Close brace: if element is in braces, keep nesting count and * quit when the last close brace is seen. */ - case '}': - if (openBraces > 1) { - openBraces--; - } else if (openBraces == 1) { - size = (p - elemStart); - p++; - if ((p >= limit) - || isspace(UCHAR(*p))) { /* INTL: ISO space. */ - goto done; - } + case '}': + if (openBraces > 1) { + openBraces--; + } else if (openBraces == 1) { + size = (p - elemStart); + p++; + if ((p >= limit) + || isspace(UCHAR(*p))) { /* INTL: ISO space. */ + goto done; + } - /* - * Garbage after the closing brace; return an error. - */ - - if (interp != NULL) { - char buf[100]; - - p2 = p; - while ((p2 < limit) - && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ - && (p2 < p+20)) { - p2++; - } - sprintf(buf, - "list element in braces followed by \"%.*s\" instead of space", - (int) (p2-p), p); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + /* + * Garbage after the closing brace; return an error. + */ + + if (interp != NULL) { + char buf[100]; + + p2 = p; + while ((p2 < limit) + && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ + && (p2 < p+20)) { + p2++; } - return TCL_ERROR; + sprintf(buf, + "list element in braces followed by \"%.*s\" instead of space", + (int) (p2-p), p); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } - break; + return TCL_ERROR; + } + break; /* - * Backslash: skip over everything up to the end of the - * backslash sequence. + * Backslash: skip over everything up to the end of the backslash + * sequence. */ - case '\\': { - Tcl_UtfBackslash(p, &numChars, NULL); - p += (numChars - 1); - break; - } + case '\\': + Tcl_UtfBackslash(p, &numChars, NULL); + p += (numChars - 1); + break; /* * Space: ignore if element is in braces or quotes; otherwise * terminate element. */ - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': - if ((openBraces == 0) && !inQuotes) { - size = (p - elemStart); - goto done; - } - break; + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + if ((openBraces == 0) && !inQuotes) { + size = (p - elemStart); + goto done; + } + break; /* * Double-quote: if element is in quotes then terminate it. */ - case '"': - if (inQuotes) { - size = (p - elemStart); - p++; - if ((p >= limit) - || isspace(UCHAR(*p))) { /* INTL: ISO space */ - goto done; - } + case '"': + if (inQuotes) { + size = (p - elemStart); + p++; + if ((p >= limit) + || isspace(UCHAR(*p))) { /* INTL: ISO space */ + goto done; + } - /* - * Garbage after the closing quote; return an error. - */ - - if (interp != NULL) { - char buf[100]; - - p2 = p; - while ((p2 < limit) - && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ - && (p2 < p+20)) { - p2++; - } - sprintf(buf, - "list element in quotes followed by \"%.*s\" %s", - (int) (p2-p), p, "instead of space"); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + /* + * Garbage after the closing quote; return an error. + */ + + if (interp != NULL) { + char buf[100]; + + p2 = p; + while ((p2 < limit) + && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ + && (p2 < p+20)) { + p2++; } - return TCL_ERROR; + sprintf(buf, + "list element in quotes followed by \"%.*s\" %s", + (int) (p2-p), p, "instead of space"); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } - break; + return TCL_ERROR; + } + break; } p++; } - /* * End of list: terminate element. */ @@ -348,7 +343,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, size = (p - elemStart); } - done: + done: while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ p++; } @@ -368,11 +363,11 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, * Copy a string and eliminate any backslashes that aren't in braces. * * Results: - * Count characters get copied from src to dst. Along the way, if + * Count characters get copied from src to dst. Along the way, if * backslash sequences are found outside braces, the backslashes are - * eliminated in the copy. After scanning count chars from source, a - * null character is placed at the end of dst. Returns the number - * of characters that got copied. + * eliminated in the copy. After scanning count chars from source, a null + * character is placed at the end of dst. Returns the number of + * characters that got copied. * * Side effects: * None. @@ -416,21 +411,19 @@ TclCopyAndCollapse(count, src, dst) * Splits a list up into its constituent fields. * * Results - * The return value is normally TCL_OK, which means that - * the list was successfully split up. If TCL_ERROR is - * returned, it means that "list" didn't have proper list - * structure; the interp's result will contain a more detailed - * error message. - * - * *argvPtr will be filled in with the address of an array - * whose elements point to the elements of list, in order. - * *argcPtr will get filled in with the number of valid elements - * in the array. A single block of memory is dynamically allocated - * to hold both the argv array and a copy of the list (with - * backslashes and braces removed in the standard way). - * The caller must eventually free this memory by calling free() - * on *argvPtr. Note: *argvPtr and *argcPtr are only modified - * if the procedure returns normally. + * The return value is normally TCL_OK, which means that the list was + * successfully split up. If TCL_ERROR is returned, it means that "list" + * didn't have proper list structure; the interp's result will contain a + * more detailed error message. + * + * *argvPtr will be filled in with the address of an array whose elements + * point to the elements of list, in order. *argcPtr will get filled in + * with the number of valid elements in the array. A single block of + * memory is dynamically allocated to hold both the argv array and a copy + * of the list (with backslashes and braces removed in the standard way). + * The caller must eventually free this memory by calling free() on + * *argvPtr. Note: *argvPtr and *argcPtr are only modified if the + * function returns normally. * * Side effects: * Memory is allocated. @@ -440,13 +433,13 @@ TclCopyAndCollapse(count, src, dst) int Tcl_SplitList(interp, list, argcPtr, argvPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, no error message is left. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting. If + * NULL, no error message is left. */ CONST char *list; /* Pointer to string with list structure. */ - int *argcPtr; /* Pointer to location to fill in with - * the number of elements in the list. */ - CONST char ***argvPtr; /* Pointer to place to store pointer to - * array of pointers to list elements. */ + int *argcPtr; /* Pointer to location to fill in with the + * number of elements in the list. */ + CONST char ***argvPtr; /* Pointer to place to store pointer to array + * of pointers to list elements. */ { CONST char **argv; CONST char *l; @@ -455,10 +448,10 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) CONST char *element; /* - * Figure out how much space to allocate. There must be enough - * space for both the array of pointers and also for a copy of - * the list. To estimate the number of pointers needed, count - * the number of space characters in the list. + * Figure out how much space to allocate. There must be enough space for + * both the array of pointers and also for a copy of the list. To estimate + * the number of pointers needed, count the number of space characters in + * the list. */ for (size = 1, l = list; *l != 0; l++) { @@ -473,7 +466,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { CONST char *prevList = list; - + result = TclFindElement(interp, list, length, &element, &list, &elSize, &brace); length -= (list - prevList); @@ -515,17 +508,15 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) * * Tcl_ScanElement -- * - * This procedure is a companion procedure to Tcl_ConvertElement. - * It scans a string to see what needs to be done to it (e.g. add - * backslashes or enclosing braces) to make the string into a - * valid Tcl list element. + * This function is a companion function to Tcl_ConvertElement. It scans + * a string to see what needs to be done to it (e.g. add backslashes or + * enclosing braces) to make the string into a valid Tcl list element. * * Results: - * The return value is an overestimate of the number of characters - * that will be needed by Tcl_ConvertElement to produce a valid - * list element from string. The word at *flagPtr is filled in - * with a value needed by Tcl_ConvertElement when doing the actual - * conversion. + * The return value is an overestimate of the number of characters that + * will be needed by Tcl_ConvertElement to produce a valid list element + * from string. The word at *flagPtr is filled in with a value needed by + * Tcl_ConvertElement when doing the actual conversion. * * Side effects: * None. @@ -547,19 +538,17 @@ Tcl_ScanElement(string, flagPtr) * * Tcl_ScanCountedElement -- * - * This procedure is a companion procedure to - * Tcl_ConvertCountedElement. It scans a string to see what - * needs to be done to it (e.g. add backslashes or enclosing - * braces) to make the string into a valid Tcl list element. - * If length is -1, then the string is scanned up to the first - * null byte. + * This function is a companion function to Tcl_ConvertCountedElement. It + * scans a string to see what needs to be done to it (e.g. add + * backslashes or enclosing braces) to make the string into a valid Tcl + * list element. If length is -1, then the string is scanned up to the + * first null byte. * * Results: - * The return value is an overestimate of the number of characters - * that will be needed by Tcl_ConvertCountedElement to produce a - * valid list element from string. The word at *flagPtr is - * filled in with a value needed by Tcl_ConvertCountedElement - * when doing the actual conversion. + * The return value is an overestimate of the number of characters that + * will be needed by Tcl_ConvertCountedElement to produce a valid list + * element from string. The word at *flagPtr is filled in with a value + * needed by Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: * None. @@ -578,44 +567,44 @@ Tcl_ScanCountedElement(string, length, flagPtr) register CONST char *p, *lastChar; /* - * This procedure and Tcl_ConvertElement together do two things: + * This function and Tcl_ConvertElement together do two things: + * + * 1. They produce a proper list, one that will yield back the argument + * strings when evaluated or when disassembled with Tcl_SplitList. This + * is the most important thing. * - * 1. They produce a proper list, one that will yield back the - * argument strings when evaluated or when disassembled with - * Tcl_SplitList. This is the most important thing. - * - * 2. They try to produce legible output, which means minimizing the - * use of backslashes (using braces instead). However, there are - * some situations where backslashes must be used (e.g. an element - * like "{abc": the leading brace will have to be backslashed. - * For each element, one of three things must be done: + * 2. They try to produce legible output, which means minimizing the use + * of backslashes (using braces instead). However, there are some + * situations where backslashes must be used (e.g. an element like + * "{abc": the leading brace will have to be backslashed. For each + * element, one of three things must be done: * - * (a) Use the element as-is (it doesn't contain any special - * characters). This is the most desirable option. + * (a) Use the element as-is (it doesn't contain any special + * characters). This is the most desirable option. * - * (b) Enclose the element in braces, but leave the contents alone. - * This happens if the element contains embedded space, or if it - * contains characters with special interpretation ($, [, ;, or \), - * or if it starts with a brace or double-quote, or if there are - * no characters in the element. + * (b) Enclose the element in braces, but leave the contents alone. + * This happens if the element contains embedded space, or if it + * contains characters with special interpretation ($, [, ;, or \), + * or if it starts with a brace or double-quote, or if there are no + * characters in the element. * - * (c) Don't enclose the element in braces, but add backslashes to - * prevent special interpretation of special characters. This is a - * last resort used when the argument would normally fall under case - * (b) but contains unmatched braces. It also occurs if the last - * character of the argument is a backslash or if the element contains - * a backslash followed by newline. + * (c) Don't enclose the element in braces, but add backslashes to + * prevent special interpretation of special characters. This is a + * last resort used when the argument would normally fall under + * case (b) but contains unmatched braces. It also occurs if the + * last character of the argument is a backslash or if the element + * contains a backslash followed by newline. * - * The procedure figures out how many bytes will be needed to store - * the result (actually, it overestimates). It also collects information - * about the element in the form of a flags word. + * The function figures out how many bytes will be needed to store the + * result (actually, it overestimates). It also collects information about + * the element in the form of a flags word. * - * Note: list elements produced by this procedure and + * Note: list elements produced by this function and * Tcl_ConvertCountedElement must have the property that they can be - * enclosing in curly braces to make sub-lists. This means, for - * example, that we must not leave unmatched curly braces in the - * resulting list element. This property is necessary in order for - * procedures like Tcl_DStringStartSublist to work. + * enclosing in curly braces to make sub-lists. This means, for example, + * that we must not leave unmatched curly braces in the resulting list + * element. This property is necessary in order for functions like + * Tcl_DStringStartSublist to work. */ nestingLevel = 0; @@ -631,39 +620,39 @@ Tcl_ScanCountedElement(string, length, flagPtr) if ((p == lastChar) || (*p == '{') || (*p == '"')) { flags |= USE_BRACES; } - for ( ; p < lastChar; p++) { + for (; p < lastChar; p++) { switch (*p) { - case '{': - nestingLevel++; - break; - case '}': - nestingLevel--; - if (nestingLevel < 0) { - flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; - } - break; - case '[': - case '$': - case ';': - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': - flags |= USE_BRACES; - break; - case '\\': - if ((p+1 == lastChar) || (p[1] == '\n')) { - flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; - } else { - int size; + case '{': + nestingLevel++; + break; + case '}': + nestingLevel--; + if (nestingLevel < 0) { + flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; + } + break; + case '[': + case '$': + case ';': + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + flags |= USE_BRACES; + break; + case '\\': + if ((p+1 == lastChar) || (p[1] == '\n')) { + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; + } else { + int size; - Tcl_UtfBackslash(p, &size, NULL); - p += size-1; - flags |= USE_BRACES; - } - break; + Tcl_UtfBackslash(p, &size, NULL); + p += size-1; + flags |= USE_BRACES; + } + break; } } if (nestingLevel != 0) { @@ -672,8 +661,8 @@ Tcl_ScanCountedElement(string, length, flagPtr) *flagPtr = flags; /* - * Allow enough space to backslash every character plus leave - * two spaces for braces. + * Allow enough space to backslash every character plus leave two spaces + * for braces. */ return 2*(p-string) + 2; @@ -684,16 +673,15 @@ Tcl_ScanCountedElement(string, length, flagPtr) * * Tcl_ConvertElement -- * - * This is a companion procedure to Tcl_ScanElement. Given - * the information produced by Tcl_ScanElement, this procedure - * converts a string to a list element equal to that string. + * This is a companion function to Tcl_ScanElement. Given the information + * produced by Tcl_ScanElement, this function converts a string to a list + * element equal to that string. * * Results: - * Information is copied to *dst in the form of a list element - * identical to src (i.e. if Tcl_SplitList is applied to dst it - * will produce a string identical to src). The return value is - * a count of the number of characters copied (not including the - * terminating NULL character). + * Information is copied to *dst in the form of a list element identical + * to src (i.e. if Tcl_SplitList is applied to dst it will produce a + * string identical to src). The return value is a count of the number of + * characters copied (not including the terminating NULL character). * * Side effects: * None. @@ -715,17 +703,15 @@ Tcl_ConvertElement(src, dst, flags) * * Tcl_ConvertCountedElement -- * - * This is a companion procedure to Tcl_ScanCountedElement. Given - * the information produced by Tcl_ScanCountedElement, this - * procedure converts a string to a list element equal to that - * string. + * This is a companion function to Tcl_ScanCountedElement. Given the + * information produced by Tcl_ScanCountedElement, this function converts + * a string to a list element equal to that string. * * Results: - * Information is copied to *dst in the form of a list element - * identical to src (i.e. if Tcl_SplitList is applied to dst it - * will produce a string identical to src). The return value is - * a count of the number of characters copied (not including the - * terminating NULL character). + * Information is copied to *dst in the form of a list element identical + * to src (i.e. if Tcl_SplitList is applied to dst it will produce a + * string identical to src). The return value is a count of the number of + * characters copied (not including the terminating NULL character). * * Side effects: * None. @@ -744,8 +730,8 @@ Tcl_ConvertCountedElement(src, length, dst, flags) register CONST char *lastChar; /* - * See the comment block at the beginning of the Tcl_ScanElement - * code for details of how this works. + * See the comment block at the beginning of the Tcl_ScanElement code for + * details of how this works. */ if (src && length == -1) { @@ -764,7 +750,7 @@ Tcl_ConvertCountedElement(src, length, dst, flags) if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { *p = '{'; p++; - for ( ; src != lastChar; src++, p++) { + for (; src != lastChar; src++, p++) { *p = *src; } *p = '}'; @@ -772,10 +758,10 @@ Tcl_ConvertCountedElement(src, length, dst, flags) } else { if (*src == '{') { /* - * Can't have a leading brace unless the whole element is - * enclosed in braces. Add a backslash before the brace. - * Furthermore, this may destroy the balance between open - * and close braces, so set BRACES_UNMATCHED. + * Can't have a leading brace unless the whole element is enclosed + * in braces. Add a backslash before the brace. Furthermore, this + * may destroy the balance between open and close braces, so set + * BRACES_UNMATCHED. */ p[0] = '\\'; @@ -785,9 +771,8 @@ Tcl_ConvertCountedElement(src, length, dst, flags) flags |= BRACES_UNMATCHED; } else if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { /* - * Leading '#' could be seen by [eval] as the start of - * a comment, if on the first element of a list, so - * quote it. + * Leading '#' could be seen by [eval] as the start of a comment, + * if on the first element of a list, so quote it. */ p[0] = '\\'; @@ -797,62 +782,62 @@ Tcl_ConvertCountedElement(src, length, dst, flags) } for (; src != lastChar; src++) { switch (*src) { - case ']': - case '[': - case '$': - case ';': - case ' ': - case '\\': - case '"': - *p = '\\'; - p++; - break; - case '{': - case '}': - /* - * It may not seem necessary to backslash braces, but - * it is. The reason for this is that the resulting - * list element may actually be an element of a sub-list - * enclosed in braces (e.g. if Tcl_DStringStartSublist - * has been invoked), so there may be a brace mismatch - * if the braces aren't backslashed. - */ - - if (flags & BRACES_UNMATCHED) { - *p = '\\'; - p++; - } - break; - case '\f': - *p = '\\'; - p++; - *p = 'f'; - p++; - continue; - case '\n': - *p = '\\'; - p++; - *p = 'n'; - p++; - continue; - case '\r': - *p = '\\'; - p++; - *p = 'r'; - p++; - continue; - case '\t': - *p = '\\'; - p++; - *p = 't'; - p++; - continue; - case '\v': + case ']': + case '[': + case '$': + case ';': + case ' ': + case '\\': + case '"': + *p = '\\'; + p++; + break; + case '{': + case '}': + /* + * It may not seem necessary to backslash braces, but it is. + * The reason for this is that the resulting list element may + * actually be an element of a sub-list enclosed in braces + * (e.g. if Tcl_DStringStartSublist has been invoked), so + * there may be a brace mismatch if the braces aren't + * backslashed. + */ + + if (flags & BRACES_UNMATCHED) { *p = '\\'; p++; - *p = 'v'; - p++; - continue; + } + break; + case '\f': + *p = '\\'; + p++; + *p = 'f'; + p++; + continue; + case '\n': + *p = '\\'; + p++; + *p = 'n'; + p++; + continue; + case '\r': + *p = '\\'; + p++; + *p = 'r'; + p++; + continue; + case '\t': + *p = '\\'; + p++; + *p = 't'; + p++; + continue; + case '\v': + *p = '\\'; + p++; + *p = 'v'; + p++; + continue; } *p = *src; p++; @@ -867,15 +852,14 @@ Tcl_ConvertCountedElement(src, length, dst, flags) * * Tcl_Merge -- * - * Given a collection of strings, merge them together into a - * single string that has proper Tcl list structured (i.e. - * Tcl_SplitList may be used to retrieve strings equal to the - * original elements, and Tcl_Eval will parse the string back - * into its original elements). + * Given a collection of strings, merge them together into a single + * string that has proper Tcl list structured (i.e. Tcl_SplitList may be + * used to retrieve strings equal to the original elements, and Tcl_Eval + * will parse the string back into its original elements). * * Results: - * The return value is the address of a dynamically-allocated - * string containing the merged list. + * The return value is the address of a dynamically-allocated string + * containing the merged list. * * Side effects: * None. @@ -916,7 +900,7 @@ Tcl_Merge(argc, argv) result = (char *) ckalloc((unsigned) numChars); dst = result; for (i = 0; i < argc; i++) { - numChars = Tcl_ConvertElement(argv[i], dst, + numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH) ); dst += numChars; *dst = ' '; @@ -942,10 +926,10 @@ Tcl_Merge(argc, argv) * Figure out how to handle a backslash sequence. * * Results: - * The return value is the character that should be substituted - * in place of the backslash sequence that starts at src. If - * readPtr isn't NULL then it is filled in with a count of the - * number of characters in the backslash sequence. + * The return value is the character that should be substituted in place + * of the backslash sequence that starts at src. If readPtr isn't NULL + * then it is filled in with a count of the number of characters in the + * backslash sequence. * * Side effects: * None. @@ -955,10 +939,10 @@ Tcl_Merge(argc, argv) char Tcl_Backslash(src, readPtr) - CONST char *src; /* Points to the backslash character of - * a backslash sequence. */ - int *readPtr; /* Fill in with number of characters read - * from src, unless NULL. */ + CONST char *src; /* Points to the backslash character of a + * backslash sequence. */ + int *readPtr; /* Fill in with number of characters read from + * src, unless NULL. */ { char buf[TCL_UTF_MAX]; Tcl_UniChar ch; @@ -976,13 +960,13 @@ Tcl_Backslash(src, readPtr) * Concatenate a set of strings into a single large string. * * Results: - * The return value is dynamically-allocated string containing - * a concatenation of all the strings in argv, with spaces between - * the original argv elements. + * The return value is dynamically-allocated string containing a + * concatenation of all the strings in argv, with spaces between the + * original argv elements. * * Side effects: - * Memory is allocated for the result; the caller is responsible - * for freeing the memory. + * Memory is allocated for the result; the caller is responsible for + * freeing the memory. * *---------------------------------------------------------------------- */ @@ -1009,9 +993,8 @@ Tcl_Concat(argc, argv) int length; /* - * Clip white space off the front and back of the string - * to generate a neater result, and ignore any empty - * elements. + * Clip white space off the front and back of the string to generate a + * neater result, and ignore any empty elements. */ element = argv[i]; @@ -1022,7 +1005,7 @@ Tcl_Concat(argc, argv) (length > 0) && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ && ((length < 2) || (element[length-2] != '\\')); - length--) { + length--) { /* Null loop body. */ } if (length == 0) { @@ -1050,8 +1033,8 @@ Tcl_Concat(argc, argv) * object with spaces between the original strings. * * Results: - * The return value is a new string object containing a concatenation - * of the strings in objv. Its ref count is zero. + * The return value is a new string object containing a concatenation of + * the strings in objv. Its ref count is zero. * * Side effects: * A new object is created. @@ -1071,13 +1054,13 @@ Tcl_ConcatObj(objc, objv) Tcl_Obj *objPtr; /* - * Check first to see if all the items are of list type. If so, - * we will concat them together as lists, and return a list object. - * This is only valid when the lists have no current string - * representation, since we don't know what the original type was. - * An original string rep may have lost some whitespace info when - * converted which could be important. + * Check first to see if all the items are of list type. If so, we will + * concat them together as lists, and return a list object. This is only + * valid when the lists have no current string representation, since we + * don't know what the original type was. An original string rep may have + * lost some whitespace info when converted which could be important. */ + for (i = 0; i < objc; i++) { objPtr = objv[i]; if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) { @@ -1091,10 +1074,10 @@ Tcl_ConcatObj(objc, objv) objPtr = Tcl_NewListObj(0, NULL); for (i = 0; i < objc; i++) { /* - * Tcl_ListObjAppendList could be used here, but this saves - * us a bit of type checking (since we've already done it) - * Use of INT_MAX tells us to always put the new stuff on - * the end. It will be set right in Tcl_ListObjReplace. + * Tcl_ListObjAppendList could be used here, but this saves us a + * bit of type checking (since we've already done it). Use of + * INT_MAX tells us to always put the new stuff on the end. It + * will be set right in Tcl_ListObjReplace. */ Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv); Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv); @@ -1102,6 +1085,11 @@ Tcl_ConcatObj(objc, objv) return objPtr; } + /* + * Something cannot be determined to be safe, so build the concatenation + * the slow way, using the string representations. + */ + allocSize = 0; for (i = 0; i < objc; i++) { objPtr = objv[i]; @@ -1115,17 +1103,17 @@ Tcl_ConcatObj(objc, objv) } /* - * Allocate storage for the concatenated result. Note that allocSize - * is one more than the total number of characters, and so includes - * room for the terminating NULL byte. + * Allocate storage for the concatenated result. Note that allocSize is + * one more than the total number of characters, and so includes room for + * the terminating NULL byte. */ - + concatStr = (char *) ckalloc((unsigned) allocSize); /* * Now concatenate the elements. Clip white space off the front and back - * to generate a neater result, and ignore any empty elements. Also put - * a null byte at the end. + * to generate a neater result, and ignore any empty elements. Also put a + * null byte at the end. */ finalSize = 0; @@ -1133,19 +1121,19 @@ Tcl_ConcatObj(objc, objv) *concatStr = '\0'; } else { p = concatStr; - for (i = 0; i < objc; i++) { + for (i = 0; i < objc; i++) { objPtr = objv[i]; element = Tcl_GetStringFromObj(objPtr, &elemLength); while ((elemLength > 0) && (UCHAR(*element) < 127) && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ - element++; - elemLength--; + element++; + elemLength--; } /* - * Trim trailing white space. But, be careful not to trim - * a space character if it is preceded by a backslash: in - * this case it could be significant. + * Trim trailing white space. But, be careful not to trim a space + * character if it is preceded by a backslash: in this case it + * could be significant. */ while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) @@ -1154,22 +1142,22 @@ Tcl_ConcatObj(objc, objv) elemLength--; } if (elemLength == 0) { - continue; /* nothing left of this element */ + continue; /* nothing left of this element */ } memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); p += elemLength; *p = ' '; p++; finalSize += (elemLength + 1); - } - if (p != concatStr) { + } + if (p != concatStr) { p[-1] = 0; finalSize -= 1; /* we overwrote the final ' ' */ - } else { + } else { *p = 0; - } + } } - + TclNewObj(objPtr); objPtr->bytes = concatStr; objPtr->length = finalSize; @@ -1184,10 +1172,9 @@ Tcl_ConcatObj(objc, objv) * See if a particular string matches a particular pattern. * * Results: - * The return value is 1 if string matches pattern, and - * 0 otherwise. The matching operation permits the following - * special characters in the pattern: *?\[] (see the manual - * entry for details on what these mean). + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. @@ -1209,14 +1196,13 @@ Tcl_StringMatch(str, pattern) * * Tcl_StringCaseMatch -- * - * See if a particular string matches a particular pattern. - * Allows case insensitivity. + * See if a particular string matches a particular pattern. Allows case + * insensitivity. * * Results: - * The return value is 1 if string matches pattern, and - * 0 otherwise. The matching operation permits the following - * special characters in the pattern: *?\[] (see the manual - * entry for details on what these mean). + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. @@ -1234,16 +1220,16 @@ Tcl_StringCaseMatch(str, pattern, nocase) int p, charLen; CONST char *pstart = pattern; Tcl_UniChar ch1, ch2; - + while (1) { p = *pattern; - + /* - * See if we're at the end of both the pattern and the string. If - * so, we succeeded. If we're at the end of the pattern but not at - * the end of the string, we failed. + * See if we're at the end of both the pattern and the string. If so, + * we succeeded. If we're at the end of the pattern but not at the end + * of the string, we failed. */ - + if (p == '\0') { return (*str == '\0'); } @@ -1252,24 +1238,27 @@ Tcl_StringCaseMatch(str, pattern, nocase) } /* - * Check for a "*" as the next pattern character. It matches - * any substring. We handle this by calling ourselves - * recursively for each postfix of string, until either we - * match or we reach the end of the string. + * Check for a "*" as the next pattern character. It matches any + * substring. We handle this by calling ourselves recursively for each + * postfix of string, until either we match or we reach the end of the + * string. */ - + if (p == '*') { /* * Skip all successive *'s in the pattern */ + while (*(++pattern) == '*') {} p = *pattern; if (p == '\0') { return 1; } + /* * This is a special case optimization for single-byte utf. */ + if (UCHAR(*pattern) < 0x80) { ch2 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); @@ -1278,6 +1267,7 @@ Tcl_StringCaseMatch(str, pattern, nocase) if (nocase) { ch2 = Tcl_UniCharToLower(ch2); } + } while (1) { /* @@ -1285,6 +1275,7 @@ Tcl_StringCaseMatch(str, pattern, nocase) * quickly if the next char in the pattern isn't a special * character */ + if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*str) { @@ -1297,9 +1288,10 @@ Tcl_StringCaseMatch(str, pattern, nocase) } else { /* * There's no point in trying to make this code - * shorter, as the number of bytes you want to - * compare each time is non-constant. + * shorter, as the number of bytes you want to compare + * each time is non-constant. */ + while (*str) { charLen = TclUtfToUniChar(str, &ch1); if (ch2 == ch1) { @@ -1320,8 +1312,8 @@ Tcl_StringCaseMatch(str, pattern, nocase) } /* - * Check for a "?" as the next pattern character. It matches - * any single character. + * Check for a "?" as the next pattern character. It matches any + * single character. */ if (p == '?') { @@ -1331,9 +1323,9 @@ Tcl_StringCaseMatch(str, pattern, nocase) } /* - * Check for a "[" as the next pattern character. It is followed - * by a list of characters that are acceptable, or by a range - * (two characters separated by "-"). + * Check for a "[" as the next pattern character. It is followed by a + * list of characters that are acceptable, or by a range (two + * characters separated by "-"). */ if (p == '[') { @@ -1404,8 +1396,8 @@ Tcl_StringCaseMatch(str, pattern, nocase) } /* - * If the next pattern character is '\', just strip off the '\' - * so we do exact matching on the character that follows. + * If the next pattern character is '\', just strip off the '\' so we + * do exact matching on the character that follows. */ if (p == '\\') { @@ -1416,8 +1408,8 @@ Tcl_StringCaseMatch(str, pattern, nocase) } /* - * There's no special character. Just make sure that the next - * bytes of each string match. + * There's no special character. Just make sure that the next bytes of + * each string match. */ str += TclUtfToUniChar(str, &ch1); @@ -1437,9 +1429,9 @@ Tcl_StringCaseMatch(str, pattern, nocase) * * Tcl_DStringInit -- * - * Initializes a dynamic string, discarding any previous contents - * of the string (Tcl_DStringFree should have been called already - * if the dynamic string was previously in use). + * Initializes a dynamic string, discarding any previous contents of the + * string (Tcl_DStringFree should have been called already if the dynamic + * string was previously in use). * * Results: * None. @@ -1471,9 +1463,9 @@ Tcl_DStringInit(dsPtr) * The return value is a pointer to the dynamic string's new value. * * Side effects: - * Length bytes from "bytes" (or all of "bytes" if length is less - * than zero) are added to the current value of the string. Memory - * gets reallocated if needed to accomodate the string's new size. + * Length bytes from "bytes" (or all of "bytes" if length is less than + * zero) are added to the current value of the string. Memory gets + * reallocated if needed to accomodate the string's new size. * *---------------------------------------------------------------------- */ @@ -1481,11 +1473,11 @@ Tcl_DStringInit(dsPtr) char * Tcl_DStringAppend(dsPtr, bytes, length) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ - CONST char *bytes; /* String to append. If length is -1 then - * this must be null-terminated. */ - int length; /* Number of bytes from "bytes" to - * append. If < 0, then append all of bytes, - * up to null at end. */ + CONST char *bytes; /* String to append. If length is -1 then this + * must be null-terminated. */ + int length; /* Number of bytes from "bytes" to append. If + * < 0, then append all of bytes, up to null + * at end. */ { int newSize; char *dst; @@ -1497,9 +1489,9 @@ Tcl_DStringAppend(dsPtr, bytes, length) newSize = length + dsPtr->length; /* - * Allocate a larger buffer for the string if the current one isn't - * large enough. Allocate extra space in the new buffer so that there - * will be room to grow before we have to allocate again. + * Allocate a larger buffer for the string if the current one isn't large + * enough. Allocate extra space in the new buffer so that there will be + * room to grow before we have to allocate again. */ if (newSize >= dsPtr->spaceAvl) { @@ -1518,8 +1510,7 @@ Tcl_DStringAppend(dsPtr, bytes, length) } /* - * Copy the new string into the buffer at the end of the old - * one. + * Copy the new string into the buffer at the end of the old one. */ for (dst = dsPtr->string + dsPtr->length, end = bytes+length; @@ -1542,9 +1533,9 @@ Tcl_DStringAppend(dsPtr, bytes, length) * The return value is a pointer to the dynamic string's new value. * * Side effects: - * String is reformatted as a list element and added to the current - * value of the string. Memory gets reallocated if needed to - * accomodate the string's new size. + * String is reformatted as a list element and added to the current value + * of the string. Memory gets reallocated if needed to accomodate the + * string's new size. * *---------------------------------------------------------------------- */ @@ -1552,7 +1543,7 @@ Tcl_DStringAppend(dsPtr, bytes, length) char * Tcl_DStringAppendElement(dsPtr, element) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ - CONST char *element; /* String to append. Must be + CONST char *element; /* String to append. Must be * null-terminated. */ { int newSize, flags, strSize; @@ -1563,12 +1554,11 @@ Tcl_DStringAppendElement(dsPtr, element) + dsPtr->length + 1; /* - * Allocate a larger buffer for the string if the current one isn't - * large enough. Allocate extra space in the new buffer so that there - * will be room to grow before we have to allocate again. - * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string - * to a larger buffer, since there may be embedded NULLs in the - * string in some cases. + * Allocate a larger buffer for the string if the current one isn't large + * enough. Allocate extra space in the new buffer so that there will be + * room to grow before we have to allocate again. SPECIAL NOTE: must use + * memcpy, not strcpy, to copy the string to a larger buffer, since there + * may be embedded NULLs in the string in some cases. */ if (newSize >= dsPtr->spaceAvl) { @@ -1587,8 +1577,8 @@ Tcl_DStringAppendElement(dsPtr, element) } /* - * Convert the new string to a list element and copy it into the - * buffer at the end, with a space, if needed. + * Convert the new string to a list element and copy it into the buffer at + * the end, with a space, if needed. */ dst = dsPtr->string + dsPtr->length; @@ -1596,11 +1586,13 @@ Tcl_DStringAppendElement(dsPtr, element) *dst = ' '; dst++; dsPtr->length++; + /* - * If we need a space to separate this element from preceding - * stuff, then this element will not lead a list, and need not - * have it's leading '#' quoted. + * If we need a space to separate this element from preceding stuff, + * then this element will not lead a list, and need not have it's + * leading '#' quoted. */ + flags |= TCL_DONT_QUOTE_HASH; } dsPtr->length += Tcl_ConvertCountedElement(element, strSize, dst, flags); @@ -1612,17 +1604,16 @@ Tcl_DStringAppendElement(dsPtr, element) * * Tcl_DStringSetLength -- * - * Change the length of a dynamic string. This can cause the - * string to either grow or shrink, depending on the value of - * length. + * Change the length of a dynamic string. This can cause the string to + * either grow or shrink, depending on the value of length. * * Results: * None. * * Side effects: - * The length of dsPtr is changed to length and a null byte is - * stored at that position in the string. If length is larger - * than the space allocated for dsPtr, then a panic occurs. + * The length of dsPtr is changed to length and a null byte is stored at + * that position in the string. If length is larger than the space + * allocated for dsPtr, then a panic occurs. * *---------------------------------------------------------------------- */ @@ -1639,15 +1630,15 @@ Tcl_DStringSetLength(dsPtr, length) } if (length >= dsPtr->spaceAvl) { /* - * There are two interesting cases here. In the first case, the user - * may be trying to allocate a large buffer of a specific size. It + * There are two interesting cases here. In the first case, the user + * may be trying to allocate a large buffer of a specific size. It * would be wasteful to overallocate that buffer, so we just allocate - * enough for the requested size plus the trailing null byte. In the + * enough for the requested size plus the trailing null byte. In the * second case, we are growing the buffer incrementally, so we need - * behavior similar to Tcl_DStringAppend. The requested length will - * usually be a small delta above the current spaceAvl, so we'll end up - * doubling the old size. This won't grow the buffer quite as quickly, - * but it should be close enough. + * behavior similar to Tcl_DStringAppend. The requested length will + * usually be a small delta above the current spaceAvl, so we'll end + * up doubling the old size. This won't grow the buffer quite as + * quickly, but it should be close enough. */ newsize = dsPtr->spaceAvl * 2; @@ -1677,17 +1668,18 @@ Tcl_DStringSetLength(dsPtr, length) * * Tcl_DStringFree -- * - * Frees up any memory allocated for the dynamic string and - * reinitializes the string to an empty state. + * Frees up any memory allocated for the dynamic string and reinitializes + * the string to an empty state. * * Results: * None. * * Side effects: - * The previous contents of the dynamic string are lost, and - * the new value is an empty string. + * The previous contents of the dynamic string are lost, and the new + * value is an empty string. * - *---------------------------------------------------------------------- */ + *---------------------------------------------------------------------- + */ void Tcl_DStringFree(dsPtr) @@ -1707,17 +1699,16 @@ Tcl_DStringFree(dsPtr) * * Tcl_DStringResult -- * - * This procedure moves the value of a dynamic string into an - * interpreter as its string result. Afterwards, the dynamic string - * is reset to an empty string. + * This function moves the value of a dynamic string into an interpreter + * as its string result. Afterwards, the dynamic string is reset to an + * empty string. * * Results: * None. * * Side effects: - * The string is "moved" to interp's result, and any existing - * string result for interp is freed. dsPtr is reinitialized to - * an empty string. + * The string is "moved" to interp's result, and any existing string + * result for interp is freed. dsPtr is reinitialized to an empty string. * *---------------------------------------------------------------------- */ @@ -1729,7 +1720,7 @@ Tcl_DStringResult(interp, dsPtr) * result of interp. */ { Tcl_ResetResult(interp); - + if (dsPtr->string != dsPtr->staticSpace) { interp->result = dsPtr->string; interp->freeProc = TCL_DYNAMIC; @@ -1739,7 +1730,7 @@ Tcl_DStringResult(interp, dsPtr) } else { Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); } - + dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; @@ -1751,14 +1742,14 @@ Tcl_DStringResult(interp, dsPtr) * * Tcl_DStringGetResult -- * - * This procedure moves an interpreter's result into a dynamic string. + * This function moves an interpreter's result into a dynamic string. * * Results: * None. * * Side effects: - * The interpreter's string result is cleared, and the previous - * contents of dsPtr are freed. + * The interpreter's string result is cleared, and the previous contents + * of dsPtr are freed. * * If the string result is empty, the object result is moved to the * string result, then the object result is reset. @@ -1769,18 +1760,18 @@ Tcl_DStringResult(interp, dsPtr) void Tcl_DStringGetResult(interp, dsPtr) Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ - Tcl_DString *dsPtr; /* Dynamic string that is to become the - * result of interp. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become the result + * of interp. */ { Interp *iPtr = (Interp *) interp; - + if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. + * If the string result is empty, move the object result to the string + * result, then reset the object result. */ (void) Tcl_GetStringResult(interp); @@ -1807,7 +1798,7 @@ Tcl_DStringGetResult(interp, dsPtr) } strcpy(dsPtr->string, iPtr->result); } - + iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; } @@ -1817,9 +1808,9 @@ Tcl_DStringGetResult(interp, dsPtr) * * Tcl_DStringStartSublist -- * - * This procedure adds the necessary information to a dynamic - * string (e.g. " {" to start a sublist. Future element - * appends will be in the sublist rather than the main list. + * This function adds the necessary information to a dynamic string + * (e.g. " {") to start a sublist. Future element appends will be in the + * sublist rather than the main list. * * Results: * None. @@ -1832,7 +1823,7 @@ Tcl_DStringGetResult(interp, dsPtr) void Tcl_DStringStartSublist(dsPtr) - Tcl_DString *dsPtr; /* Dynamic string. */ + Tcl_DString *dsPtr; /* Dynamic string. */ { if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { Tcl_DStringAppend(dsPtr, " {", -1); @@ -1846,10 +1837,9 @@ Tcl_DStringStartSublist(dsPtr) * * Tcl_DStringEndSublist -- * - * This procedure adds the necessary characters to a dynamic - * string to end a sublist (e.g. "}"). Future element appends - * will be in the enclosing (sub)list rather than the current - * sublist. + * This function adds the necessary characters to a dynamic string to end + * a sublist (e.g. "}"). Future element appends will be in the enclosing + * (sub)list rather than the current sublist. * * Results: * None. @@ -1862,7 +1852,7 @@ Tcl_DStringStartSublist(dsPtr) void Tcl_DStringEndSublist(dsPtr) - Tcl_DString *dsPtr; /* Dynamic string. */ + Tcl_DString *dsPtr; /* Dynamic string. */ { Tcl_DStringAppend(dsPtr, "}", -1); } @@ -1872,14 +1862,14 @@ Tcl_DStringEndSublist(dsPtr) * * Tcl_PrintDouble -- * - * Given a floating-point value, this procedure converts it to - * an ASCII string using. + * Given a floating-point value, this function converts it to an ASCII + * string using. * * Results: - * The ASCII equivalent of "value" is written at "dst". It is - * written using the current precision, and it is guaranteed to - * contain a decimal point or exponent, so that it looks like - * a floating-point value and not an integer. + * The ASCII equivalent of "value" is written at "dst". It is written + * using the current precision, and it is guaranteed to contain a decimal + * point or exponent, so that it looks like a floating-point value and + * not an integer. * * Side effects: * None. @@ -1889,13 +1879,12 @@ Tcl_DStringEndSublist(dsPtr) void Tcl_PrintDouble(interp, value, dst) - Tcl_Interp *interp; /* Interpreter whose tcl_precision - * variable used to be used to control - * printing. It's ignored now. */ - double value; /* Value to print as string. */ - char *dst; /* Where to store converted value; - * must have at least TCL_DOUBLE_SPACE - * characters. */ + Tcl_Interp *interp; /* Interpreter whose tcl_precision variable + * used to be used to control printing. It's + * ignored now. */ + double value; /* Value to print as string. */ + char *dst; /* Where to store converted value; must have + * at least TCL_DOUBLE_SPACE characters. */ { char *p, c; int prec; @@ -1909,64 +1898,71 @@ Tcl_PrintDouble(interp, value, dst) Tcl_MutexUnlock(&precisionMutex); /* - * If prec == 0, then use TclDoubleDigits to develop a decimal - * significand and exponent, then format it in E or F format as - * appropriate. If prec != 0, use the native sprintf and then - * add a trailing ".0" if there is no decimal point in the rep. + * If prec == 0, then use TclDoubleDigits to develop a decimal significand + * and exponent, then format it in E or F format as appropriate. If prec + * != 0, use the native sprintf and then add a trailing ".0" if there is + * no decimal point in the rep. */ if ( prec == 0 ) { + /* + * Handle NaN. + */ - /* Handle NaN */ - - if ( IS_NAN( value ) ) { - TclFormatNaN( value, dst ); + if (IS_NAN(value)) { + TclFormatNaN(value, dst); return; } - /* Handle infinities */ + /* + * Handle infinities. + */ - if ( IS_INF( value ) ) { - if ( value < 0 ) { - strcpy( dst, "-Inf" ); + if (IS_INF(value)) { + if (value < 0) { + strcpy(dst, "-Inf"); } else { - strcpy( dst, "Inf" ); + strcpy(dst, "Inf"); } return; } - /* Ordinary (normal and denormal) values */ + /* + * Ordinary (normal and denormal) values. + */ - exp = TclDoubleDigits( buffer, value, &signum ); - if ( signum ) { + exp = TclDoubleDigits(buffer, value, &signum); + if (signum) { *dst++ = '-'; } - prec = strlen( buffer ); + prec = strlen(buffer); p = buffer; - if ( exp < -3 || exp > 17 ) { - - /* E format for numbers < 1e-3 or >= 1e17 */ + if (exp < -3 || exp > 17) { + /* + * E format for numbers < 1e-3 or >= 1e17. + */ *dst++ = *p++; c = *p; - if ( c != '\0' ) { + if (c != '\0') { *dst++ = '.'; - while ( c != '\0' ) { + while (c != '\0') { *dst++ = c; c = *++p; } } - sprintf( dst, "e%+d", exp-1 ); + sprintf(dst, "e%+d", exp-1); } else { + /* + * F format for others. + */ - /* F format for others */ - - if ( exp <= 0 ) { + if (exp <= 0) { *dst++ = '0'; } c = *p; - while ( exp-- > 0 ) { - if ( c != '\0' ) { + while (exp-- > 0) { + if (c != '\0') { *dst++ = c; c = *++p; } else { @@ -1974,13 +1970,13 @@ Tcl_PrintDouble(interp, value, dst) } } *dst++ = '.'; - if ( c == '\0' ) { + if (c == '\0') { *dst++ = '0'; } else { - while ( ++exp < 0 ) { + while (++exp < 0) { *dst++ = '0'; } - while ( c != '\0' ) { + while (c != '\0') { *dst++ = c; c = *++p; } @@ -1989,18 +1985,19 @@ Tcl_PrintDouble(interp, value, dst) } } else { + /* + * tcl_precision is supplied, pass it to the native sprintf. + */ - /* tcl_precision is supplied, pass it to the native sprintf */ + sprintf(dst, "%.*g", prec, value); - sprintf( dst, "%.*g", prec, value ); - /* * If the ASCII result looks like an integer, add ".0" so that it - * doesn't look like an integer anymore. This prevents floating-point - * values from being converted to integers unintentionally. - * Check for ASCII specifically to speed up the function. + * doesn't look like an integer anymore. This prevents floating-point + * values from being converted to integers unintentionally. Check for + * ASCII specifically to speed up the function. */ - + for (p = dst; *p != 0; ) { if (UCHAR(*p) < 0x80) { c = *p++; @@ -2024,17 +2021,17 @@ Tcl_PrintDouble(interp, value, dst) * * TclPrecTraceProc -- * - * This procedure is invoked whenever the variable "tcl_precision" - * is written. + * This function is invoked whenever the variable "tcl_precision" is + * written. * * Results: - * Returns NULL if all went well, or an error message if the - * new value for the variable doesn't make sense. + * Returns NULL if all went well, or an error message if the new value + * for the variable doesn't make sense. * * Side effects: - * If the new value doesn't make sense then this procedure - * undoes the effect of the variable modification. Otherwise - * it modifies the format string that's used by Tcl_PrintDouble. + * If the new value doesn't make sense then this function undoes the + * effect of the variable modification. Otherwise it modifies the format + * string that's used by Tcl_PrintDouble. * *---------------------------------------------------------------------- */ @@ -2065,43 +2062,40 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) } /* - * When the variable is read, reset its value from our shared - * value. This is needed in case the variable was modified in - * some other interpreter so that this interpreter's value is - * out of date. + * When the variable is read, reset its value from our shared value. This + * is needed in case the variable was modified in some other interpreter + * so that this interpreter's value is out of date. */ if (flags & TCL_TRACE_READS) { Tcl_MutexLock(&precisionMutex); - Tcl_SetVar2Ex( interp, name1, name2, Tcl_NewIntObj( precision ), - flags & TCL_GLOBAL_ONLY ); + Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(precision), + flags & TCL_GLOBAL_ONLY); Tcl_MutexUnlock(&precisionMutex); return (char *) NULL; } /* - * The variable is being written. Check the new value and disallow - * it if it isn't reasonable or if this is a safe interpreter (we - * don't want safe interpreters messing up the precision of other - * interpreters). + * The variable is being written. Check the new value and disallow it if + * it isn't reasonable or if this is a safe interpreter (we don't want + * safe interpreters messing up the precision of other interpreters). */ if (Tcl_IsSafe(interp)) { Tcl_MutexLock(&precisionMutex); - Tcl_SetVar2Ex( interp, name1, name2, Tcl_NewIntObj( precision ), - flags & TCL_GLOBAL_ONLY ); + Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(precision), + flags & TCL_GLOBAL_ONLY); Tcl_MutexUnlock(&precisionMutex); return "can't modify precision from a safe interpreter"; } value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); - if ( value == NULL - || Tcl_GetIntFromObj( (Tcl_Interp*) NULL, value, &prec ) != TCL_OK - || prec < 0 - || prec > TCL_MAX_PREC ) { + if (value == NULL + || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK + || prec < 0 || prec > TCL_MAX_PREC) { return "improper value for precision"; } - Tcl_MutexLock( &precisionMutex ); + Tcl_MutexLock(&precisionMutex); precision = prec; Tcl_MutexUnlock(&precisionMutex); return (char *) NULL; @@ -2112,9 +2106,8 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) * * TclNeedSpace -- * - * This procedure checks to see whether it is appropriate to - * add a space before appending a new list element to an - * existing string. + * This function checks to see whether it is appropriate to add a space + * before appending a new list element to an existing string. * * Results: * The return value is 1 if a space is appropriate, 0 otherwise. @@ -2128,22 +2121,23 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) int TclNeedSpace(start, end) CONST char *start; /* First character in string. */ - CONST char *end; /* End of string (place where space will - * be added, if appropriate). */ + CONST char *end; /* End of string (place where space will be + * added, if appropriate). */ { /* - * A space is needed unless either + * A space is needed unless either: * (a) we're at the start of the string, or */ + if (end == start) { return 0; } /* - * (b) we're at the start of a nested list-element, quoted with an - * open curly brace; we can be nested arbitrarily deep, so long - * as the first curly brace starts an element, so backtrack over - * open curly braces that are trailing characters of the string; and + * (b) we're at the start of a nested list-element, quoted with an open + * curly brace; we can be nested arbitrarily deep, so long as the + * first curly brace starts an element, so backtrack over open curly + * braces that are trailing characters of the string; and */ end = Tcl_UtfPrev(end, start); @@ -2156,39 +2150,39 @@ TclNeedSpace(start, end) /* * (c) the trailing character of the string is already a list-element - * separator (according to TclFindElement); that is, one of these - * characters: - * \u0009 \t TAB - * \u000A \n NEWLINE - * \u000B \v VERTICAL TAB - * \u000C \f FORM FEED - * \u000D \r CARRIAGE RETURN - * \u0020 SPACE - * with the condition that the penultimate character is not a - * backslash. + * separator (according to TclFindElement); that is, one of these + * characters: + * \u0009 \t TAB + * \u000A \n NEWLINE + * \u000B \v VERTICAL TAB + * \u000C \f FORM FEED + * \u000D \r CARRIAGE RETURN + * \u0020 SPACE + * with the condition that the penultimate character is not a + * backslash. */ if (*end > 0x20) { /* - * Performance tweak. All ASCII spaces are <= 0x20. So get - * a quick answer for most characters before comparing against - * all spaces in the switch below. + * Performance tweak. All ASCII spaces are <= 0x20. So get a quick + * answer for most characters before comparing against all spaces in + * the switch below. * - * NOTE: Remove this if other Unicode spaces ever get accepted - * as list-element separators. + * NOTE: Remove this if other Unicode spaces ever get accepted as + * list-element separators. */ return 1; } switch (*end) { - case ' ': - case '\t': - case '\n': - case '\r': - case '\v': - case '\f': - if ((end == start) || (end[-1] != '\\')) { - return 0; - } + case ' ': + case '\t': + case '\n': + case '\r': + case '\v': + case '\f': + if ((end == start) || (end[-1] != '\\')) { + return 0; + } } return 1; } @@ -2198,15 +2192,15 @@ TclNeedSpace(start, end) * * TclLooksLikeInt -- * - * This procedure decides whether the leading characters of a - * string look like an integer or something else (such as a - * floating-point number or string). + * This function decides whether the leading characters of a string look + * like an integer or something else (such as a floating-point number or + * string). * * Results: - * The return value is 1 if the leading characters of p look - * like a valid Tcl integer. If they look like a floating-point - * number (e.g. "e01" or "2.4"), or if they don't look like a - * number at all, then 0 is returned. + * The return value is 1 if the leading characters of p look like a valid + * Tcl integer. If they look like a floating-point number (e.g. "e01" or + * "2.4"), or if they don't look like a number at all, then 0 is + * returned. * * Side effects: * None. @@ -2217,10 +2211,9 @@ TclNeedSpace(start, end) int TclLooksLikeInt(bytes, length) register CONST char *bytes; /* Points to first byte of the string. */ - int length; /* Number of bytes in the string. If < 0 - * bytes up to the first null byte are - * considered (if they may appear in an - * integer). */ + int length; /* Number of bytes in the string. If < 0 bytes + * up to the first null byte are considered + * (if they may appear in an integer). */ { register CONST char *p; @@ -2229,7 +2222,7 @@ TclLooksLikeInt(bytes, length) } if (length < 0) { - length = (bytes? strlen(bytes) : 0); + length = (bytes? strlen(bytes) : 0); } p = bytes; @@ -2237,10 +2230,11 @@ TclLooksLikeInt(bytes, length) length--; p++; } if (length == 0) { - return 0; + return 0; } if ((*p == '+') || (*p == '-')) { - p++; length--; + p++; + length--; } return (0 != TclParseInteger(p, length)); @@ -2251,33 +2245,32 @@ TclLooksLikeInt(bytes, length) * * TclGetIntForIndex -- * - * This procedure returns an integer corresponding to the list index - * held in a Tcl object. The Tcl object's value is expected to be - * in the format integer([+-]integer)? or the format end([+-]integer)?. + * This function returns an integer corresponding to the list index held + * in a Tcl object. The Tcl object's value is expected to be in the + * format integer([+-]integer)? or the format end([+-]integer)?. * * Results: * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If - * the Tcl object referenced by "objPtr" has the value "end", the - * value stored is "endValue". If "objPtr"s values is not of one - * of the expected formats, TCL_ERROR is returned and, if - * "interp" is non-NULL, an error message is left in the interpreter's - * result object. + * successfully stored into the location referenced by "indexPtr". If the + * Tcl object referenced by "objPtr" has the value "end", the value + * stored is "endValue". If "objPtr"s values is not of one of the + * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, + * an error message is left in the interpreter's result object. * * Side effects: - * The object referenced by "objPtr" might be converted to an - * integer, wide integer, or end-based-index object. + * The object referenced by "objPtr" might be converted to an integer, + * wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ int TclGetIntForIndex(interp, objPtr, endValue, indexPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, then no error message is left - * after errors. */ - Tcl_Obj *objPtr; /* Points to an object containing either - * "end" or an integer. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + Tcl_Obj *objPtr; /* Points to an object containing either "end" + * or an integer. */ int endValue; /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ int *indexPtr; /* Location filled in with an integer @@ -2289,8 +2282,8 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { /* - * If the object is already an offset from the end of the - * list, or can be converted to one, use it. + * If the object is already an offset from the end of the list, or can + * be converted to one, use it. */ *indexPtr = endValue + objPtr->internalRep.longValue; @@ -2304,7 +2297,7 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) length--; p++; } if (length == 0) { - goto parseError; + goto parseError; } if ((*p == '+') || (*p == '-')) { p++; length--; @@ -2340,14 +2333,16 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) * Report a parse error. */ -parseError: + parseError: if (interp != NULL) { char *bytes = Tcl_GetString(objPtr); + /* - * The result might not be empty; this resets it which - * should be both a cheap operation, and of little problem - * because this is an error-generation path anyway. + * The result might not be empty; this resets it which should be + * both a cheap operation, and of little problem because this is + * an error-generation path anyway. */ + Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be integer?[+-]integer? or end?[+-]integer?", @@ -2360,7 +2355,7 @@ parseError: return TCL_ERROR; } - + return TCL_OK; } @@ -2378,9 +2373,8 @@ parseError: * Side effects: * Stores a valid string in the object's string rep. * - * This procedure does NOT free any earlier string rep. If it is - * called on an object that already has a valid string rep, it will - * leak memory. + * This function does NOT free any earlier string rep. If it is called on an + * object that already has a valid string rep, it will leak memory. * *---------------------------------------------------------------------- */ @@ -2408,35 +2402,39 @@ UpdateStringOfEndOffset(objPtr) * * SetEndOffsetFromAny -- * - * Look for a string of the form "end[+-]offset" and convert it - * to an internal representation holding the offset. + * Look for a string of the form "end[+-]offset" and convert it to an + * internal representation holding the offset. * * Results: * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. * * Side effects: - * If interp is not NULL, stores an error message in the - * interpreter result. + * If interp is not NULL, stores an error message in the interpreter + * result. * *---------------------------------------------------------------------- */ static int SetEndOffsetFromAny(interp, objPtr) - Tcl_Interp* interp; /* Tcl interpreter or NULL */ - Tcl_Obj* objPtr; /* Pointer to the object to parse */ + Tcl_Interp *interp; /* Tcl interpreter or NULL */ + Tcl_Obj* objPtr; /* Pointer to the object to parse */ { int offset; /* Offset in the "end-offset" expression */ register char* bytes; /* String rep of the object */ int length; /* Length of the object's string rep */ - /* If it's already the right type, we're fine. */ + /* + * If it's already the right type, we're fine. + */ if (objPtr->typePtr == &tclEndOffsetType) { return TCL_OK; } - /* Check for a string rep of the right form. */ + /* + * Check for a string rep of the right form. + */ bytes = Tcl_GetStringFromObj(objPtr, &length); if ((*bytes != 'e') || (strncmp(bytes, "end", @@ -2449,15 +2447,18 @@ SetEndOffsetFromAny(interp, objPtr) return TCL_ERROR; } - /* Convert the string rep */ + /* + * Convert the string rep. + */ if (length <= 3) { offset = 0; } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* - * This is our limited string expression evaluator. Pass everything + * This is our limited string expression evaluator. Pass everything * after "end-" to Tcl_GetInt, then reverse for offset. */ + if (isspace(UCHAR(bytes[4]))) { return TCL_ERROR; } @@ -2469,8 +2470,9 @@ SetEndOffsetFromAny(interp, objPtr) } } else { /* - * Conversion failed. Report the error. + * Conversion failed. Report the error. */ + if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, @@ -2480,8 +2482,8 @@ SetEndOffsetFromAny(interp, objPtr) } /* - * The conversion succeeded. Free the old internal rep and set - * the new one. + * The conversion succeeded. Free the old internal rep and set the new + * one. */ TclFreeIntRep(objPtr); @@ -2489,15 +2491,15 @@ SetEndOffsetFromAny(interp, objPtr) objPtr->typePtr = &tclEndOffsetType; return TCL_OK; -} +} /* *---------------------------------------------------------------------- * * TclCheckBadOctal -- * - * This procedure checks for a bad octal value and appends a - * meaningful error to the interp's result. + * This function checks for a bad octal value and appends a meaningful + * error to the interp's result. * * Results: * 1 if the argument was a bad octal, else 0. @@ -2510,16 +2512,16 @@ SetEndOffsetFromAny(interp, objPtr) int TclCheckBadOctal(interp, value) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, then no error message is left - * after errors. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ CONST char *value; /* String to check. */ { register CONST char *p = value; /* - * A frequent mistake is invalid octal values due to an unwanted - * leading zero. Try to generate a meaningful error message. + * A frequent mistake is invalid octal values due to an unwanted leading + * zero. Try to generate a meaningful error message. */ while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ @@ -2536,11 +2538,14 @@ TclCheckBadOctal(interp, value) p++; } if (*p == '\0') { - /* Reached end of string */ + /* + * Reached end of string. + */ + if (interp != NULL) { /* - * Don't reset the result here because we want this result - * to be added to an existing error message as extra info. + * Don't reset the result here because we want this result to + * be added to an existing error message as extra info. */ Tcl_AppendResult(interp, " (looks like invalid octal number)", (char *) NULL); @@ -2555,6 +2560,7 @@ TclCheckBadOctal(interp, value) *---------------------------------------------------------------------- * * ClearHash -- + * * Remove all the entries in the hash table *tablePtr. * *---------------------------------------------------------------------- @@ -2580,16 +2586,15 @@ ClearHash(tablePtr) * * GetThreadHash -- * - * Get a thread-specific (Tcl_HashTable *) associated with a - * thread data key. + * Get a thread-specific (Tcl_HashTable *) associated with a thread data + * key. * * Results: - * The Tcl_HashTable * corresponding to *keyPtr. + * The Tcl_HashTable * corresponding to *keyPtr. * * Side effects: - * The first call on a keyPtr in each thread creates a new - * Tcl_HashTable, and registers a thread exit handler to - * dispose of it. + * The first call on a keyPtr in each thread creates a new Tcl_HashTable, + * and registers a thread exit handler to dispose of it. * *---------------------------------------------------------------------- */ @@ -2612,8 +2617,9 @@ GetThreadHash(keyPtr) *---------------------------------------------------------------------- * * FreeThreadHash -- - * Thread exit handler used by GetThreadHash to dispose - * of a thread hash table. + * + * Thread exit handler used by GetThreadHash to dispose of a thread hash + * table. * * Side effects: * Frees a Tcl_HashTable. @@ -2623,7 +2629,7 @@ GetThreadHash(keyPtr) static void FreeThreadHash(clientData) - ClientData clientData; + ClientData clientData; { Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; ClearHash(tablePtr); @@ -2635,15 +2641,16 @@ FreeThreadHash(clientData) *---------------------------------------------------------------------- * * FreeProcessGlobalValue -- - * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup - * a ProcessGlobalValue at exit. + * + * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup a + * ProcessGlobalValue at exit. * *---------------------------------------------------------------------- */ static void FreeProcessGlobalValue(clientData) - ClientData clientData; + ClientData clientData; { ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData; pgvPtr->epoch++; @@ -2662,11 +2669,12 @@ FreeProcessGlobalValue(clientData) * * TclSetProcessGlobalValue -- * - * Utility routine to set a global value shared by all threads in - * the process while keeping a thread-local copy as well. + * Utility routine to set a global value shared by all threads in the + * process while keeping a thread-local copy as well. * *---------------------------------------------------------------------- */ + void TclSetProcessGlobalValue(pgvPtr, newValue, encoding) ProcessGlobalValue *pgvPtr; @@ -2679,7 +2687,11 @@ TclSetProcessGlobalValue(pgvPtr, newValue, encoding) int dummy; Tcl_MutexLock(&pgvPtr->mutex); - /* Fill the global string value */ + + /* + * Fill the global string value. + */ + pgvPtr->epoch++; if (NULL != pgvPtr->value) { ckfree(pgvPtr->value); @@ -2695,10 +2707,11 @@ TclSetProcessGlobalValue(pgvPtr, newValue, encoding) pgvPtr->encoding = encoding; /* - * Fill the local thread copy directly with the Tcl_Obj - * value to avoid loss of the intrep. Increment newValue - * refCount early to handle case where we set a PGV to itself. + * Fill the local thread copy directly with the Tcl_Obj value to avoid + * loss of the intrep. Increment newValue refCount early to handle case + * where we set a PGV to itself. */ + Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); @@ -2732,12 +2745,12 @@ TclGetProcessGlobalValue(pgvPtr) if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); - if (pgvPtr->encoding != current) { + if (pgvPtr->encoding != current) { /* - * The system encoding has changed since the master - * string value was saved. Convert the master value - * to be based on the new system encoding. + * The system encoding has changed since the master string value + * was saved. Convert the master value to be based on the new + * system encoding. */ Tcl_DString native, newValue; @@ -2753,7 +2766,7 @@ TclGetProcessGlobalValue(pgvPtr) ckfree(pgvPtr->value); pgvPtr->value = ckalloc((unsigned int) Tcl_DStringLength(&newValue) + 1); - memcpy((VOID *) pgvPtr->value, (VOID *) Tcl_DStringValue(&newValue), + memcpy((VOID*) pgvPtr->value, (VOID*) Tcl_DStringValue(&newValue), (size_t) Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); Tcl_FreeEncoding(pgvPtr->encoding); @@ -2768,12 +2781,19 @@ TclGetProcessGlobalValue(pgvPtr) if (NULL == hPtr) { int dummy; - /* No cache for the current epoch - must be a new one */ - /* First, clear the cacheMap, as anything in it must - * refer to some expired epoch.*/ + /* + * No cache for the current epoch - must be a new one. + * + * First, clear the cacheMap, as anything in it must refer to some + * expired epoch. + */ + ClearHash(cacheMap); - /* If no thread has set the shared value, call the initializer */ + /* + * If no thread has set the shared value, call the initializer. + */ + Tcl_MutexLock(&pgvPtr->mutex); if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { pgvPtr->epoch++; @@ -2785,7 +2805,10 @@ TclGetProcessGlobalValue(pgvPtr) Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); } - /* Store a copy of the shared value in our epoch-indexed cache */ + /* + * Store a copy of the shared value in our epoch-indexed cache. + */ + value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); @@ -2800,9 +2823,8 @@ TclGetProcessGlobalValue(pgvPtr) * * TclSetObjNameOfExecutable -- * - * This procedure stores the absolute pathname of - * the executable file (normally as computed by - * TclpFindExecutable). + * This function stores the absolute pathname of the executable file + * (normally as computed by TclpFindExecutable). * * Results: * None. @@ -2826,15 +2848,14 @@ TclSetObjNameOfExecutable(name, encoding) * * TclGetObjNameOfExecutable -- * - * This procedure retrieves the absolute pathname of the - * application in which the Tcl library is running, usually - * as previously stored by TclpFindExecutable(). - * This procedure call is the C API equivalent to the - * "info nameofexecutable" command. + * This function retrieves the absolute pathname of the application in + * which the Tcl library is running, usually as previously stored by + * TclpFindExecutable(). This function call is the C API equivalent to + * the "info nameofexecutable" command. * * Results: - * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if - * the pathname of the application is unknown. + * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if the + * pathname of the application is unknown. * * Side effects: * None. @@ -2853,17 +2874,15 @@ TclGetObjNameOfExecutable() * * Tcl_GetNameOfExecutable -- * - * This procedure retrieves the absolute pathname of the - * application in which the Tcl library is running, and - * returns it in string form. + * This function retrieves the absolute pathname of the application in + * which the Tcl library is running, and returns it in string form. * - * The returned string belongs to Tcl and should be copied - * if the caller plans to keep it, to guard against it - * becoming invalid. + * The returned string belongs to Tcl and should be copied if the caller + * plans to keep it, to guard against it becoming invalid. * * Results: - * A pointer to the internal string or NULL if the internal full - * path name has not been computed or unknown. + * A pointer to the internal string or NULL if the internal full path + * name has not been computed or unknown. * * Side effects: * None. @@ -2888,7 +2907,9 @@ Tcl_GetNameOfExecutable() * * TclpGetTime -- * - * Deprecated synonym for Tcl_GetTime. + * Deprecated synonym for Tcl_GetTime. This function is provided for the + * benefit of extensions written before Tcl_GetTime was exported from the + * library. * * Results: * None. @@ -2896,9 +2917,6 @@ Tcl_GetNameOfExecutable() * Side effects: * Stores current time in the buffer designated by "timePtr" * - * This procedure is provided for the benefit of extensions written - * before Tcl_GetTime was exported from the library. - * *---------------------------------------------------------------------- */ @@ -2914,14 +2932,14 @@ TclpGetTime(timePtr) * * TclGetPlatform -- * - * This is a kludge that allows the test library to get access - * the internal tclPlatform variable. + * This is a kludge that allows the test library to get access the + * internal tclPlatform variable. * * Results: - * Returns a pointer to the tclPlatform variable. + * Returns a pointer to the tclPlatform variable. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -2931,3 +2949,11 @@ TclGetPlatform() { return &tclPlatform; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |