summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclConfig.c256
-rw-r--r--generic/tclFCmd.c615
-rw-r--r--generic/tclGet.c80
-rw-r--r--generic/tclPreserve.c272
-rw-r--r--generic/tclResult.c541
-rw-r--r--generic/tclStringObj.c995
-rwxr-xr-xgeneric/tclThreadAlloc.c194
-rw-r--r--generic/tclTimer.c596
-rw-r--r--generic/tclUtil.c1486
-rw-r--r--unix/tclUnixNotfy.c407
-rw-r--r--unix/tclUnixPipe.c531
-rw-r--r--unix/tclXtNotify.c291
-rw-r--r--win/tclAppInit.c159
-rw-r--r--win/tclWin32Dll.c1220
-rw-r--r--win/tclWinChan.c511
-rw-r--r--win/tclWinConsole.c440
-rw-r--r--win/tclWinDde.c292
-rw-r--r--win/tclWinFCmd.c1127
-rw-r--r--win/tclWinFile.c2344
-rw-r--r--win/tclWinInit.c196
-rw-r--r--win/tclWinLoad.c169
-rw-r--r--win/tclWinNotify.c234
-rw-r--r--win/tclWinPipe.c1289
-rw-r--r--win/tclWinReg.c363
-rw-r--r--win/tclWinSerial.c689
-rw-r--r--win/tclWinSock.c1391
-rw-r--r--win/tclWinThrd.c485
-rw-r--r--win/tclWinTime.c894
28 files changed, 9361 insertions, 8706 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:
+ */
diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c
index b0052d4..3c4dbee 100644
--- a/unix/tclUnixNotfy.c
+++ b/unix/tclUnixNotfy.c
@@ -1,64 +1,68 @@
/*
* tclUnixNotify.c --
*
- * This file contains the implementation of the select-based
- * Unix-specific notifier, which is the lowest-level part
- * of the Tcl event loop. This file works together with
- * generic/tclNotify.c.
+ * This file contains the implementation of the select()-based
+ * Unix-specific notifier, which is the lowest-level part of the Tcl
+ * event loop. This file works together with generic/tclNotify.c.
*
* Copyright (c) 1995-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: tclUnixNotfy.c,v 1.27 2005/07/01 10:29:12 vasiljevic Exp $
+ * RCS: @(#) $Id: tclUnixNotfy.c,v 1.28 2005/07/24 22:56:44 dkf Exp $
*/
-#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier
- * is in tclMacOSXNotify.c */
+#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is
+ * in tclMacOSXNotify.c */
#include "tclInt.h"
#include <signal.h>
+/*
+ * This code does deep stub magic to allow replacement of the notifier at
+ * runtime.
+ */
+
extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;
/*
- * This structure is used to keep track of the notifier info for a
- * a registered file.
+ * This structure is used to keep track of the notifier info for a registered
+ * file.
*/
typedef struct FileHandler {
int fd;
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
- int readyMask; /* Mask of events that have been seen since the
- * last time file handlers were invoked for
- * this file. */
- Tcl_FileProc *proc; /* Procedure to call, in the style of
+ int readyMask; /* Mask of events that have been seen since
+ * the last time file handlers were invoked
+ * for this file. */
+ Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
ClientData clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;
/*
- * The following structure is what is added to the Tcl event queue when
- * file handlers are ready to fire.
+ * The following structure is what is added to the Tcl event queue when file
+ * handlers are ready to fire.
*/
typedef struct FileHandlerEvent {
- Tcl_Event header; /* Information that is standard for
- * all events. */
- int fd; /* File descriptor that is ready. Used
- * to find the FileHandler structure for
- * the file (can't point directly to the
- * FileHandler structure because it could
- * go away while the event is queued). */
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ int fd; /* File descriptor that is ready. Used to find
+ * the FileHandler structure for the file
+ * (can't point directly to the FileHandler
+ * structure because it could go away while
+ * the event is queued). */
} FileHandlerEvent;
/*
*
- * The following structure contains a set of select() masks to track
- * readable, writable, and exceptional conditions.
+ * The following structure contains a set of select() masks to track readable,
+ * writable, and exceptional conditions.
*/
typedef struct SelectMasks {
@@ -69,42 +73,41 @@ typedef struct SelectMasks {
/*
* The following static structure contains the state information for the
- * select based implementation of the Tcl notifier. One of these structures
- * is created for each thread that is using the notifier.
+ * select based implementation of the Tcl notifier. One of these structures is
+ * created for each thread that is using the notifier.
*/
typedef struct ThreadSpecificData {
FileHandler *firstFileHandlerPtr;
/* Pointer to head of file handler list. */
-
- SelectMasks checkMasks; /* This structure is used to build up the masks
- * to be used in the next call to select.
- * Bits are set in response to calls to
- * Tcl_CreateFileHandler. */
+ SelectMasks checkMasks; /* This structure is used to build up the
+ * masks to be used in the next call to
+ * select. Bits are set in response to calls
+ * to Tcl_CreateFileHandler. */
SelectMasks readyMasks; /* This array reflects the readable/writable
* conditions that were found to exist by the
* last call to select. */
- int numFdBits; /* Number of valid bits in checkMasks
- * (one more than highest fd for which
+ int numFdBits; /* Number of valid bits in checkMasks (one
+ * more than highest fd for which
* Tcl_WatchFile has been called). */
#ifdef TCL_THREADS
int onList; /* True if it is in this list */
- unsigned int pollState; /* pollState is used to implement a polling
+ unsigned int pollState; /* pollState is used to implement a polling
* handshake between each thread and the
* notifier thread. Bits defined below. */
struct ThreadSpecificData *nextPtr, *prevPtr;
- /* All threads that are currently waiting on
+ /* All threads that are currently waiting on
* an event have their ThreadSpecificData
* structure on a doubly-linked listed formed
* from these pointers. You must hold the
* notifierMutex lock before accessing these
* fields. */
- Tcl_Condition waitCV; /* Any other thread alerts a notifier
- * that an event is ready to be processed
- * by signaling this condition variable. */
+ Tcl_Condition waitCV; /* Any other thread alerts a notifier that an
+ * event is ready to be processed by signaling
+ * this condition variable. */
int eventReady; /* True if an event is ready to be processed.
- * Used as condition flag together with
- * waitCV above. */
+ * Used as condition flag together with waitCV
+ * above. */
#endif
} ThreadSpecificData;
@@ -112,8 +115,8 @@ static Tcl_ThreadDataKey dataKey;
#ifdef TCL_THREADS
/*
- * The following static indicates the number of threads that have
- * initialized notifiers.
+ * The following static indicates the number of threads that have initialized
+ * notifiers.
*
* You must hold the notifierMutex lock before accessing this variable.
*/
@@ -121,9 +124,9 @@ static Tcl_ThreadDataKey dataKey;
static int notifierCount = 0;
/*
- * The following variable points to the head of a doubly-linked list of
- * of ThreadSpecificData structures for all threads that are currently
- * waiting on an event.
+ * The following variable points to the head of a doubly-linked list of
+ * ThreadSpecificData structures for all threads that are currently waiting on
+ * an event.
*
* You must hold the notifierMutex lock before accessing this list.
*/
@@ -131,16 +134,15 @@ static int notifierCount = 0;
static ThreadSpecificData *waitingListPtr = NULL;
/*
- * The notifier thread spends all its time in select() waiting for a
- * file descriptor associated with one of the threads on the waitingListPtr
- * list to do something interesting. But if the contents of the
- * waitingListPtr list ever changes, we need to wake up and restart
- * the select() system call. You can wake up the notifier thread by
- * writing a single byte to the file descriptor defined below. This
- * file descriptor is the input-end of a pipe and the notifier thread is
- * listening for data on the output-end of the same pipe. Hence writing
- * to this file descriptor will cause the select() system call to return
- * and wake up the notifier thread.
+ * The notifier thread spends all its time in select() waiting for a file
+ * descriptor associated with one of the threads on the waitingListPtr list to
+ * do something interesting. But if the contents of the waitingListPtr list
+ * ever changes, we need to wake up and restart the select() system call. You
+ * can wake up the notifier thread by writing a single byte to the file
+ * descriptor defined below. This file descriptor is the input-end of a pipe
+ * and the notifier thread is listening for data on the output-end of the same
+ * pipe. Hence writing to this file descriptor will cause the select() system
+ * call to return and wake up the notifier thread.
*
* You must hold the notifierMutex lock before accessing this list.
*/
@@ -148,34 +150,35 @@ static ThreadSpecificData *waitingListPtr = NULL;
static int triggerPipe = -1;
/*
- * The notifierMutex locks access to all of the global notifier state.
+ * The notifierMutex locks access to all of the global notifier state.
*/
TCL_DECLARE_MUTEX(notifierMutex)
/*
* The notifier thread signals the notifierCV when it has finished
- * initializing the triggerPipe and right before the notifier
- * thread terminates.
+ * initializing the triggerPipe and right before the notifier thread
+ * terminates.
*/
static Tcl_Condition notifierCV;
/*
- * The pollState bits
+ * The pollState bits:
* POLL_WANT is set by each thread before it waits on its condition
- * variable. It is checked by the notifier before it does
- * select.
- * POLL_DONE is set by the notifier if it goes into select after
- * seeing POLL_WANT. The idea is to ensure it tries a select
- * with the same bits the initial thread had set.
+ * variable. It is checked by the notifier before it does select.
+ * POLL_DONE is set by the notifier if it goes into select after seeing
+ * POLL_WANT. The idea is to ensure it tries a select with the
+ * same bits the initial thread had set.
*/
+
#define POLL_WANT 0x1
#define POLL_DONE 0x2
/*
* This is the thread ID of the notifier thread that does select.
*/
+
static Tcl_ThreadId notifierThread;
#endif
@@ -244,15 +247,15 @@ Tcl_InitNotifier()
*
* Tcl_FinalizeNotifier --
*
- * This function is called to cleanup the notifier state before
- * a thread is terminated.
+ * This function is called to cleanup the notifier state before a thread
+ * is terminated.
*
* Results:
* None.
*
* Side effects:
- * May terminate the background notifier thread if this is the
- * last notifier instance.
+ * May terminate the background notifier thread if this is the last
+ * notifier instance.
*
*----------------------------------------------------------------------
*/
@@ -268,8 +271,8 @@ Tcl_FinalizeNotifier(clientData)
notifierCount--;
/*
- * If this is the last thread to use the notifier, close the notifier
- * pipe and wait for the background thread to terminate.
+ * If this is the last thread to use the notifier, close the notifier pipe
+ * and wait for the background thread to terminate.
*/
if (notifierCount == 0) {
@@ -279,14 +282,14 @@ Tcl_FinalizeNotifier(clientData)
}
/*
- * Send "q" message to the notifier thread so that it will
- * terminate. The notifier will return from its call to select()
- * and notice that a "q" message has arrived, it will then close
- * its side of the pipe and terminate its thread. Note the we can
- * not just close the pipe and check for EOF in the notifier
- * thread because if a background child process was created with
- * exec, select() would not register the EOF on the pipe until the
- * child processes had terminated. [Bug: 4139] [Bug: 1222872]
+ * Send "q" message to the notifier thread so that it will terminate.
+ * The notifier will return from its call to select() and notice that
+ * a "q" message has arrived, it will then close its side of the pipe
+ * and terminate its thread. Note the we can not just close the pipe
+ * and check for EOF in the notifier thread because if a background
+ * child process was created with exec, select() would not register
+ * the EOF on the pipe until the child processes had terminated. [Bug:
+ * 4139] [Bug: 1222872]
*/
write(triggerPipe, "q", 1);
@@ -315,18 +318,16 @@ Tcl_FinalizeNotifier(clientData)
*
* Tcl_AlertNotifier --
*
- * Wake up the specified notifier from any thread. This routine
- * is called by the platform independent notifier code whenever
- * the Tcl_ThreadAlert routine is called. This routine is
- * guaranteed not to be called on a given notifier after
- * Tcl_FinalizeNotifier is called for that notifier.
+ * Wake up the specified notifier from any thread. This routine is called
+ * by the platform independent notifier code whenever the Tcl_ThreadAlert
+ * routine is called. This routine is guaranteed not to be called on a
+ * given notifier after Tcl_FinalizeNotifier is called for that notifier.
*
* Results:
* None.
*
* Side effects:
- * Signals the notifier condition variable for the specified
- * notifier.
+ * Signals the notifier condition variable for the specified notifier.
*
*----------------------------------------------------------------------
*/
@@ -349,9 +350,9 @@ Tcl_AlertNotifier(clientData)
*
* Tcl_SetTimer --
*
- * This procedure sets the current notifier timer value. This
- * interface is not implemented in this notifier because we are
- * always running inside of Tcl_DoOneEvent.
+ * This function sets the current notifier timer value. This interface is
+ * not implemented in this notifier because we are always running inside
+ * of Tcl_DoOneEvent.
*
* Results:
* None.
@@ -367,9 +368,9 @@ Tcl_SetTimer(timePtr)
Tcl_Time *timePtr; /* Timeout value, may be NULL. */
{
/*
- * The interval timer doesn't do anything in this implementation,
- * because the only event loop is via Tcl_DoOneEvent, which passes
- * timeout values to Tcl_WaitForEvent.
+ * The interval timer doesn't do anything in this implementation, because
+ * the only event loop is via Tcl_DoOneEvent, which passes timeout values
+ * to Tcl_WaitForEvent.
*/
if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
@@ -405,7 +406,7 @@ Tcl_ServiceModeHook(mode)
*
* Tcl_CreateFileHandler --
*
- * This procedure registers a file handler with the select notifier.
+ * This function registers a file handler with the select notifier.
*
* Results:
* None.
@@ -420,11 +421,11 @@ void
Tcl_CreateFileHandler(fd, mask, proc, clientData)
int fd; /* Handle of stream to watch. */
int mask; /* OR'ed combination of TCL_READABLE,
- * TCL_WRITABLE, and TCL_EXCEPTION:
- * indicates conditions under which
- * proc should be called. */
- Tcl_FileProc *proc; /* Procedure to call for each
- * selected event. */
+ * TCL_WRITABLE, and TCL_EXCEPTION: indicates
+ * conditions under which proc should be
+ * called. */
+ Tcl_FileProc *proc; /* Function to call for each selected
+ * event. */
ClientData clientData; /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -481,8 +482,7 @@ Tcl_CreateFileHandler(fd, mask, proc, clientData)
*
* Tcl_DeleteFileHandler --
*
- * Cancel a previously-arranged callback arrangement for
- * a file.
+ * Cancel a previously-arranged callback arrangement for a file.
*
* Results:
* None.
@@ -495,7 +495,8 @@ Tcl_CreateFileHandler(fd, mask, proc, clientData)
void
Tcl_DeleteFileHandler(fd)
- int fd; /* Stream id for which to remove callback procedure. */
+ int fd; /* Stream id for which to remove callback
+ * function. */
{
FileHandler *filePtr, *prevPtr;
int i;
@@ -511,7 +512,7 @@ Tcl_DeleteFileHandler(fd)
*/
for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ;
- prevPtr = filePtr, filePtr = filePtr->nextPtr) {
+ prevPtr = filePtr, filePtr = filePtr->nextPtr) {
if (filePtr == NULL) {
return;
}
@@ -567,19 +568,19 @@ Tcl_DeleteFileHandler(fd)
*
* FileHandlerEventProc --
*
- * This procedure is called by Tcl_ServiceEvent when a file event
- * reaches the front of the event queue. This procedure is
- * responsible for actually handling the event by invoking the
- * callback for the file handler.
+ * This function is called by Tcl_ServiceEvent when a file event reaches
+ * the front of the event queue. This function is responsible for
+ * actually handling the event by invoking the callback for the file
+ * handler.
*
* 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_FILE_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_FILE_EVENTS flag bit isn't set.
*
* Side effects:
- * Whatever the file handler's callback procedure does.
+ * Whatever the file handler's callback function does.
*
*----------------------------------------------------------------------
*/
@@ -587,8 +588,8 @@ Tcl_DeleteFileHandler(fd)
static int
FileHandlerEventProc(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. */
{
int mask;
FileHandler *filePtr;
@@ -601,9 +602,9 @@ FileHandlerEventProc(evPtr, flags)
/*
* Search through the file handlers to find the one whose handle matches
- * the event. We do this rather than keeping a pointer to the file
- * handler directly in the event, so that the handler can be deleted
- * while the event is queued without leaving a dangling pointer.
+ * the event. We do this rather than keeping a pointer to the file handler
+ * directly in the event, so that the handler can be deleted while the
+ * event is queued without leaving a dangling pointer.
*/
tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -615,14 +616,14 @@ FileHandlerEventProc(evPtr, flags)
/*
* The code is tricky for two reasons:
- * 1. The file handler's desired events could have changed
- * since the time when the event was queued, so AND the
- * ready mask with the desired mask.
- * 2. The file could have been closed and re-opened since
- * the time when the event was queued. This is why the
- * ready mask is stored in the file handler rather than
- * the queued event: it will be zeroed when a new
- * file handler is created for the newly opened file.
+ * 1. The file handler's desired events could have changed since the
+ * time when the event was queued, so AND the ready mask with the
+ * desired mask.
+ * 2. The file could have been closed and re-opened since the time
+ * when the event was queued. This is why the ready mask is stored
+ * in the file handler rather than the queued event: it will be
+ * zeroed when a new file handler is created for the newly opened
+ * file.
*/
mask = filePtr->readyMask & filePtr->mask;
@@ -640,13 +641,12 @@ FileHandlerEventProc(evPtr, flags)
*
* Tcl_WaitForEvent --
*
- * This function is called by Tcl_DoOneEvent to wait for new
- * events on the message queue. If the block time is 0, then
- * Tcl_WaitForEvent just polls without blocking.
+ * This function is called by Tcl_DoOneEvent to wait for new events on
+ * the message queue. If the block time is 0, then Tcl_WaitForEvent just
+ * polls without blocking.
*
* Results:
- * Returns -1 if the select would block forever, otherwise
- * returns 0.
+ * Returns -1 if the select would block forever, otherwise returns 0.
*
* Side effects:
* Queues file events that are detected by the select.
@@ -666,13 +666,15 @@ Tcl_WaitForEvent(timePtr)
int waitForFiles;
Tcl_Time *myTimePtr;
#else
- /* Impl. notes: timeout & timeoutPtr are used if, and only if
- * threads are not enabled. They are the arguments for the regular
- * select() used when the core is not thread-enabled. */
+ /*
+ * Impl. notes: timeout & timeoutPtr are used if, and only if threads are
+ * not enabled. They are the arguments for the regular select() used when
+ * the core is not thread-enabled.
+ */
struct timeval timeout, *timeoutPtr;
int numFound;
-#endif
+#endif /* TCL_THREADS */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
@@ -680,15 +682,16 @@ Tcl_WaitForEvent(timePtr)
}
/*
- * Set up the timeout structure. Note that if there are no events to
- * check for, we return with a negative result rather than blocking
- * forever.
+ * Set up the timeout structure. Note that if there are no events to check
+ * for, we return with a negative result rather than blocking forever.
*/
if (timePtr != NULL) {
- /* TIP #233 (Virtualized Time). Is virtual time in effect ?
- * And do we actually have something to scale ? If yes to both
- * then we call the handler to do this scaling */
+ /*
+ * TIP #233 (Virtualized Time). Is virtual time in effect? And do we
+ * actually have something to scale? If yes to both then we call the
+ * handler to do this scaling.
+ */
myTime.sec = timePtr->sec;
myTime.usec = timePtr->usec;
@@ -700,29 +703,29 @@ Tcl_WaitForEvent(timePtr)
#ifdef TCL_THREADS
myTimePtr = &myTime;
#else
- timeout.tv_sec = myTime.sec;
+ timeout.tv_sec = myTime.sec;
timeout.tv_usec = myTime.usec;
- timeoutPtr = &timeout;
-#endif
+ timeoutPtr = &timeout;
+#endif /* TCL_THREADS */
#ifndef TCL_THREADS
} else if (tsdPtr->numFdBits == 0) {
/*
- * If there are no threads, no timeout, and no fds registered,
- * then there are no events possible and we must avoid deadlock.
- * Note that this is not entirely correct because there might
- * be a signal that could interrupt the select call, but we
- * don't handle that case if we aren't using threads.
+ * If there are no threads, no timeout, and no fds registered, then
+ * there are no events possible and we must avoid deadlock. Note that
+ * this is not entirely correct because there might be a signal that
+ * could interrupt the select call, but we don't handle that case if
+ * we aren't using threads.
*/
return -1;
-#endif
+#endif /* !TCL_THREADS */
} else {
#ifdef TCL_THREADS
myTimePtr = NULL;
#else
timeoutPtr = NULL;
-#endif
+#endif /* TCL_THREADS */
}
#ifdef TCL_THREADS
@@ -737,10 +740,10 @@ Tcl_WaitForEvent(timePtr)
if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) {
/*
* Cannot emulate a polling select with a polling condition variable.
- * Instead, pretend to wait for files and tell the notifier
- * thread what we are doing. The notifier thread makes sure
- * it goes through select with its select mask in the same state
- * as ours currently is. We block until that happens.
+ * Instead, pretend to wait for files and tell the notifier thread
+ * what we are doing. The notifier thread makes sure it goes through
+ * select with its select mask in the same state as ours currently is.
+ * We block until that happens.
*/
waitForFiles = 1;
@@ -752,9 +755,9 @@ Tcl_WaitForEvent(timePtr)
if (waitForFiles) {
/*
- * Add the ThreadSpecificData structure of this thread to the list
- * of ThreadSpecificData structures of all threads that are waiting
- * on file events.
+ * Add the ThreadSpecificData structure of this thread to the list of
+ * ThreadSpecificData structures of all threads that are waiting on
+ * file events.
*/
tsdPtr->nextPtr = waitingListPtr;
@@ -773,14 +776,14 @@ Tcl_WaitForEvent(timePtr)
FD_ZERO(&(tsdPtr->readyMasks.exceptional));
if (!tsdPtr->eventReady) {
- Tcl_ConditionWait(&tsdPtr->waitCV, &notifierMutex, myTimePtr);
+ Tcl_ConditionWait(&tsdPtr->waitCV, &notifierMutex, myTimePtr);
}
tsdPtr->eventReady = 0;
if (waitForFiles && tsdPtr->onList) {
/*
* Remove the ThreadSpecificData structure of this thread from the
- * waiting list. Alert the notifier thread to recompute its select
+ * waiting list. Alert the notifier thread to recompute its select
* masks - skipping this caused a hang when trying to close a pipe
* which the notifier thread was still doing a select on.
*/
@@ -798,26 +801,23 @@ Tcl_WaitForEvent(timePtr)
write(triggerPipe, "", 1);
}
-
#else
tsdPtr->readyMasks = tsdPtr->checkMasks;
- numFound = select( tsdPtr->numFdBits,
- &(tsdPtr->readyMasks.readable),
- &(tsdPtr->readyMasks.writable),
- &(tsdPtr->readyMasks.exceptional),
- timeoutPtr );
+ numFound = select(tsdPtr->numFdBits, &(tsdPtr->readyMasks.readable),
+ &(tsdPtr->readyMasks.writable), &(tsdPtr->readyMasks.exceptional),
+ timeoutPtr);
/*
- * Some systems don't clear the masks after an error, so
- * we have to do it here.
+ * Some systems don't clear the masks after an error, so we have to do it
+ * here.
*/
if (numFound == -1) {
- FD_ZERO( &(tsdPtr->readyMasks.readable ) );
- FD_ZERO( &(tsdPtr->readyMasks.writable ) );
- FD_ZERO( &(tsdPtr->readyMasks.exceptional ) );
+ FD_ZERO(&(tsdPtr->readyMasks.readable));
+ FD_ZERO(&(tsdPtr->readyMasks.writable));
+ FD_ZERO(&(tsdPtr->readyMasks.exceptional));
}
-#endif
+#endif /* TCL_THREADS */
/*
* Queue all detected file events before returning.
@@ -842,8 +842,8 @@ Tcl_WaitForEvent(timePtr)
}
/*
- * Don't bother to queue an event if the mask was previously
- * non-zero since an event must still be on the queue.
+ * Don't bother to queue an event if the mask was previously non-zero
+ * since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
@@ -856,7 +856,7 @@ Tcl_WaitForEvent(timePtr)
}
#ifdef TCL_THREADS
Tcl_MutexUnlock(&notifierMutex);
-#endif
+#endif /* TCL_THREADS */
return 0;
}
@@ -867,21 +867,20 @@ Tcl_WaitForEvent(timePtr)
* NotifierThreadProc --
*
* This routine is the initial (and only) function executed by the
- * special notifier thread. Its job is to wait for file descriptors
- * to become readable or writable or to have an exception condition
- * and then to notify other threads who are interested in this
- * information by signalling a condition variable. Other threads
- * can signal this notifier thread of a change in their interests
- * by writing a single byte to a special pipe that the notifier
- * thread is monitoring.
+ * special notifier thread. Its job is to wait for file descriptors to
+ * become readable or writable or to have an exception condition and then
+ * to notify other threads who are interested in this information by
+ * signalling a condition variable. Other threads can signal this
+ * notifier thread of a change in their interests by writing a single
+ * byte to a special pipe that the notifier thread is monitoring.
*
* Result:
- * None. Once started, this routine never exits. It dies with
- * the overall process.
+ * None. Once started, this routine never exits. It dies with the overall
+ * process.
*
* Side effects:
- * The trigger pipe used to signal the notifier thread is created
- * when the notifier thread first starts.
+ * The trigger pipe used to signal the notifier thread is created when
+ * the notifier thread first starts.
*
*----------------------------------------------------------------------
*/
@@ -924,7 +923,7 @@ NotifierThreadProc(clientData)
if (ioctl(fds[1], (int) FIONBIO, &status) < 0) {
Tcl_Panic("NotifierThreadProc: could not make trigger pipe non blocking.");
}
-#endif
+#endif /* FIONBIO */
/*
* Install the write end of the pipe into the global variable.
@@ -950,8 +949,8 @@ NotifierThreadProc(clientData)
FD_ZERO(&exceptionalMask);
/*
- * Compute the logical OR of the select masks from all the
- * waiting notifiers.
+ * Compute the logical OR of the select masks from all the waiting
+ * notifiers.
*/
Tcl_MutexLock(&notifierMutex);
@@ -973,8 +972,8 @@ NotifierThreadProc(clientData)
}
if (tsdPtr->pollState & POLL_WANT) {
/*
- * Here we make sure we go through select() with the same
- * mask bits that were present when the thread tried to poll.
+ * Here we make sure we go through select() with the same mask
+ * bits that were present when the thread tried to poll.
*/
tsdPtr->pollState |= POLL_DONE;
@@ -1031,10 +1030,10 @@ NotifierThreadProc(clientData)
tsdPtr->eventReady = 1;
if (tsdPtr->onList) {
/*
- * Remove the ThreadSpecificData structure of this
- * thread from the waiting list. This prevents us from
- * continuously spining on select until the other
- * threads runs and services the file event.
+ * Remove the ThreadSpecificData structure of this thread
+ * from the waiting list. This prevents us from
+ * continuously spining on select until the other threads
+ * runs and services the file event.
*/
if (tsdPtr->prevPtr) {
@@ -1056,8 +1055,8 @@ NotifierThreadProc(clientData)
/*
* Consume the next byte from the notifier pipe if the pipe was
- * readable. Note that there may be multiple bytes pending, but
- * to avoid a race condition we only read one at a time.
+ * readable. Note that there may be multiple bytes pending, but to
+ * avoid a race condition we only read one at a time.
*/
if (FD_ISSET(receivePipe, &readableMask)) {
@@ -1065,9 +1064,9 @@ NotifierThreadProc(clientData)
if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) {
/*
- * Someone closed the write end of the pipe or sent us a
- * Quit message [Bug: 4139] and then closed the write end
- * of the pipe so we need to shut down the notifier thread.
+ * Someone closed the write end of the pipe or sent us a Quit
+ * message [Bug: 4139] and then closed the write end of the
+ * pipe so we need to shut down the notifier thread.
*/
break;
@@ -1088,6 +1087,14 @@ NotifierThreadProc(clientData)
TclpThreadExit (0);
}
-#endif
+#endif /* TCL_THREADS */
#endif /* HAVE_COREFOUNDATION */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c
index c0dcb46..b19f042 100644
--- a/unix/tclUnixPipe.c
+++ b/unix/tclUnixPipe.c
@@ -1,16 +1,16 @@
-/*
+/*
* tclUnixPipe.c --
*
- * This file implements the UNIX-specific exec pipeline functions,
- * the "pipe" channel driver, and the "pid" Tcl command.
+ * This file implements the UNIX-specific exec pipeline functions, the
+ * "pipe" channel driver, and the "pid" Tcl command.
*
* Copyright (c) 1991-1994 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: tclUnixPipe.c,v 1.29 2005/06/22 19:48:10 kennykb Exp $
+ * RCS: @(#) $Id: tclUnixPipe.c,v 1.30 2005/07/24 22:56:45 dkf Exp $
*/
#include "tclInt.h"
@@ -20,7 +20,7 @@
#endif
/*
- * The following macros convert between TclFile's and fd's. The conversion
+ * The following macros convert between TclFile's and fd's. The conversion
* simple involves shifting fd's up by one to ensure that no valid fd is ever
* the same as NULL.
*/
@@ -33,16 +33,17 @@
*/
typedef struct PipeState {
- Tcl_Channel channel;/* Channel associated with this file. */
- TclFile inFile; /* Output from pipe. */
- TclFile outFile; /* Input to pipe. */
- TclFile errorFile; /* Error output from pipe. */
- int numPids; /* How many processes are attached to this pipe? */
- Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by
- * the creator of the pipe. */
- int isNonBlocking; /* Nonzero when the pipe is in nonblocking mode.
- * Used to decide whether to wait for the children
- * at close time. */
+ Tcl_Channel channel; /* Channel associated with this file. */
+ TclFile inFile; /* Output from pipe. */
+ TclFile outFile; /* Input to pipe. */
+ TclFile errorFile; /* Error output from pipe. */
+ int numPids; /* How many processes are attached to this
+ * pipe? */
+ Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by
+ * the creator of the pipe. */
+ int isNonBlocking; /* Nonzero when the pipe is in nonblocking
+ * mode. Used to decide whether to wait for
+ * the children at close time. */
} PipeState;
/*
@@ -65,8 +66,8 @@ static void RestoreSignals _ANSI_ARGS_((void));
static int SetupStdFile _ANSI_ARGS_((TclFile file, int type));
/*
- * This structure describes the channel type structure for command pipe
- * based IO:
+ * This structure describes the channel type structure for command pipe based
+ * I/O:
*/
static Tcl_ChannelType pipeChannelType = {
@@ -84,8 +85,8 @@ static Tcl_ChannelType pipeChannelType = {
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
- NULL, /* wide seek proc */
- NULL, /* thread action proc */
+ NULL, /* wide seek proc */
+ NULL, /* thread action proc */
};
/*
@@ -111,9 +112,9 @@ TclpMakeFile(channel, direction)
{
ClientData data;
- if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &data)
- == TCL_OK) {
- return MakeFile((int)data);
+ if (Tcl_GetChannelHandle(channel, direction,
+ (ClientData *) &data) == TCL_OK) {
+ return MakeFile((int) data);
} else {
return (TclFile) NULL;
}
@@ -124,7 +125,7 @@ TclpMakeFile(channel, direction)
*
* TclpOpenFile --
*
- * Open a file for use in a pipeline.
+ * Open a file for use in a pipeline.
*
* Results:
* Returns a new TclFile handle or NULL on failure.
@@ -148,11 +149,11 @@ TclpOpenFile(fname, mode)
fd = TclOSopen(native, mode, 0666); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (fd != -1) {
- fcntl(fd, F_SETFD, FD_CLOEXEC);
+ fcntl(fd, F_SETFD, FD_CLOEXEC);
/*
- * If the file is being opened for writing, seek to the end
- * so we can append to any data already in the file.
+ * If the file is being opened for writing, seek to the end so we can
+ * append to any data already in the file.
*/
if (mode & O_WRONLY) {
@@ -160,8 +161,8 @@ TclpOpenFile(fname, mode)
}
/*
- * Increment the fd so it can't be 0, which would conflict with
- * the NULL return for errors.
+ * Increment the fd so it can't be 0, which would conflict with the
+ * NULL return for errors.
*/
return MakeFile(fd);
@@ -174,9 +175,9 @@ TclpOpenFile(fname, mode)
*
* TclpCreateTempFile --
*
- * This function creates a temporary file initialized with an
- * optional string, and returns a file handle with the file pointer
- * at the beginning of the file.
+ * This function creates a temporary file initialized with an optional
+ * string, and returns a file handle with the file pointer at the
+ * beginning of the file.
*
* Results:
* A handle to a file.
@@ -241,7 +242,7 @@ TclpCreateTempFile(contents)
*----------------------------------------------------------------------
*/
-Tcl_Obj*
+Tcl_Obj *
TclpTempFileName()
{
char fileName[L_tmpnam + 9];
@@ -265,7 +266,7 @@ TclpTempFileName()
unlink(fileName); /* INTL: Native. */
result = TclpNativeToNormalized((ClientData) fileName);
- close (fd);
+ close(fd);
return result;
}
@@ -274,23 +275,23 @@ TclpTempFileName()
*
* TclpCreatePipe --
*
- * Creates a pipe - simply calls the pipe() function.
+ * Creates a pipe - simply calls the pipe() function.
*
* Results:
- * Returns 1 on success, 0 on failure.
+ * Returns 1 on success, 0 on failure.
*
* Side effects:
- * Creates a pipe.
+ * Creates a pipe.
*
*----------------------------------------------------------------------
*/
int
TclpCreatePipe(readPipe, writePipe)
- TclFile *readPipe; /* Location to store file handle for
- * read side of pipe. */
- TclFile *writePipe; /* Location to store file handle for
- * write side of pipe. */
+ TclFile *readPipe; /* Location to store file handle for read side
+ * of pipe. */
+ TclFile *writePipe; /* Location to store file handle for write
+ * side of pipe. */
{
int pipeIds[2];
@@ -331,11 +332,11 @@ TclpCloseFile(file)
/*
* Refuse to close the fds for stdin, stdout and stderr.
*/
-
+
if ((fd == 0) || (fd == 1) || (fd == 2)) {
- return 0;
+ return 0;
}
-
+
Tcl_DeleteFileHandler(fd);
return close(fd);
}
@@ -345,28 +346,27 @@ TclpCloseFile(file)
*
* TclpCreateProcess --
*
- * Create a child process that has the specified files as its
- * standard input, output, and error. The child process runs
- * asynchronously and runs with the same environment variables
- * as the creating process.
+ * Create a child process that has the specified files as its standard
+ * input, output, and error. The child process runs asynchronously and
+ * runs with the same environment variables as the creating process.
*
- * The path is searched to find the specified executable.
+ * The path is searched to find the specified executable.
*
* Results:
- * The return value is TCL_ERROR and an error message is left in
- * the interp's result if there was a problem creating the child
- * process. Otherwise, the return value is TCL_OK and *pidPtr is
- * filled with the process id of the child process.
- *
+ * The return value is TCL_ERROR and an error message is left in the
+ * interp's result if there was a problem creating the child process.
+ * Otherwise, the return value is TCL_OK and *pidPtr is filled with the
+ * process id of the child process.
+ *
* Side effects:
* A process is created.
- *
+ *
*---------------------------------------------------------------------------
*/
/* ARGSUSED */
int
-TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
+TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
pidPtr)
Tcl_Interp *interp; /* Interpreter in which to leave errors that
* occurred when creating the child process.
@@ -376,24 +376,24 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
CONST char **argv; /* Array of argument strings in UTF-8.
* argv[0] contains the name of the executable
* translated using Tcl_TranslateFileName
- * call). Additional arguments have not been
+ * call). Additional arguments have not been
* converted. */
- TclFile inputFile; /* If non-NULL, gives the file to use as
- * input for the child process. If inputFile
- * file is not readable or is NULL, the child
- * will receive no standard input. */
- TclFile outputFile; /* If non-NULL, gives the file that
- * receives output from the child process. If
+ TclFile inputFile; /* If non-NULL, gives the file to use as input
+ * for the child process. If inputFile file is
+ * not readable or is NULL, the child will
+ * receive no standard input. */
+ TclFile outputFile; /* If non-NULL, gives the file that receives
+ * output from the child process. If
* outputFile file is not writeable or is
* NULL, output from the child will be
* discarded. */
- TclFile errorFile; /* If non-NULL, gives the file that
- * receives errors from the child process. If
- * errorFile file is not writeable or is NULL,
- * errors from the child will be discarded.
- * errorFile may be the same as outputFile. */
- Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr
- * is filled with the process id of the child
+ TclFile errorFile; /* If non-NULL, gives the file that receives
+ * errors from the child process. If errorFile
+ * file is not writeable or is NULL, errors
+ * from the child will be discarded. errorFile
+ * may be the same as outputFile. */
+ Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr is
+ * filled with the process id of the child
* process. */
{
TclFile errPipeIn, errPipeOut;
@@ -402,14 +402,14 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
Tcl_DString *dsArray;
char **newArgv;
int pid, i;
-
+
errPipeIn = NULL;
errPipeOut = NULL;
pid = -1;
/*
- * Create a pipe that the child can use to return error
- * information if anything goes wrong.
+ * Create a pipe that the child can use to return error information if
+ * anything goes wrong.
*/
if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) {
@@ -419,9 +419,10 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
}
/*
- * We need to allocate and convert this before the fork
- * so it is properly deallocated later
+ * We need to allocate and convert this before the fork so it is properly
+ * deallocated later
*/
+
dsArray = (Tcl_DString *) ckalloc(argc * sizeof(Tcl_DString));
newArgv = (char **) ckalloc((argc+1) * sizeof(char *));
newArgv[argc] = NULL;
@@ -442,8 +443,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
|| !SetupStdFile(outputFile, TCL_STDOUT)
|| (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR))
|| (joinThisError &&
- ((dup2(1,2) == -1) ||
- (fcntl(2, F_SETFD, 0) != 0)))) {
+ ((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) {
sprintf(errSpace,
"%dforked process couldn't set up input/output: ", errno);
write(fd, errSpace, (size_t) strlen(errSpace));
@@ -460,10 +460,11 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
write(fd, errSpace, (size_t) strlen(errSpace));
_exit(1);
}
-
+
/*
* Free the mem we used for the fork
*/
+
for (i = 0; i < argc; i++) {
Tcl_DStringFree(&dsArray[i]);
}
@@ -477,9 +478,9 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
}
/*
- * Read back from the error pipe to see if the child started
- * up OK. The info in the pipe (if any) consists of a decimal
- * errno value followed by an error message.
+ * Read back from the error pipe to see if the child started up OK. The
+ * info in the pipe (if any) consists of a decimal errno value followed by
+ * an error message.
*/
TclpCloseFile(errPipeOut);
@@ -495,23 +496,23 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
(char *) NULL);
goto error;
}
-
+
TclpCloseFile(errPipeIn);
*pidPtr = (Tcl_Pid) pid;
return TCL_OK;
- error:
+ error:
if (pid != -1) {
/*
- * Reap the child process now if an error occurred during its
- * startup. We don't call this with WNOHANG because that can lead to
- * defunct processes on an MP system. We shouldn't have to worry
- * about hanging here, since this is the error case. [Bug: 6148]
+ * Reap the child process now if an error occurred during its startup.
+ * We don't call this with WNOHANG because that can lead to defunct
+ * processes on an MP system. We shouldn't have to worry about hanging
+ * here, since this is the error case. [Bug: 6148]
*/
Tcl_WaitPid((Tcl_Pid) pid, &status, 0);
}
-
+
if (errPipeIn) {
TclpCloseFile(errPipeIn);
}
@@ -526,19 +527,19 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
*
* RestoreSignals --
*
- * This procedure is invoked in a forked child process just before
- * exec-ing a new program to restore all signals to their default
- * settings.
+ * This procedure is invoked in a forked child process just before
+ * exec-ing a new program to restore all signals to their default
+ * settings.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * Signal settings get changed.
+ * Signal settings get changed.
*
*----------------------------------------------------------------------
*/
-
+
static void
RestoreSignals()
{
@@ -600,10 +601,10 @@ RestoreSignals()
*
* SetupStdFile --
*
- * Set up stdio file handles for the child process, using the
- * current standard channels if no other files are specified.
- * If no standard channel is defined, or if no file is associated
- * with the channel, then the corresponding standard fd is closed.
+ * Set up stdio file handles for the child process, using the current
+ * standard channels if no other files are specified. If no standard
+ * channel is defined, or if no file is associated with the channel, then
+ * the corresponding standard fd is closed.
*
* Results:
* Returns 1 on success, or 0 on failure.
@@ -626,18 +627,18 @@ SetupStdFile(file, type)
* variables. */
switch (type) {
- case TCL_STDIN:
- targetFd = 0;
- direction = TCL_READABLE;
- break;
- case TCL_STDOUT:
- targetFd = 1;
- direction = TCL_WRITABLE;
- break;
- case TCL_STDERR:
- targetFd = 2;
- direction = TCL_WRITABLE;
- break;
+ case TCL_STDIN:
+ targetFd = 0;
+ direction = TCL_READABLE;
+ break;
+ case TCL_STDOUT:
+ targetFd = 1;
+ direction = TCL_WRITABLE;
+ break;
+ case TCL_STDERR:
+ targetFd = 2;
+ direction = TCL_WRITABLE;
+ break;
}
if (!file) {
@@ -653,13 +654,13 @@ SetupStdFile(file, type)
return 0;
}
- /*
- * Must clear the close-on-exec flag for the target FD, since
- * some systems (e.g. Ultrix) do not clear the CLOEXEC flag on
- * the target FD.
- */
-
- fcntl(targetFd, F_SETFD, 0);
+ /*
+ * Must clear the close-on-exec flag for the target FD, since some
+ * systems (e.g. Ultrix) do not clear the CLOEXEC flag on the
+ * target FD.
+ */
+
+ fcntl(targetFd, F_SETFD, 0);
} else {
/*
* Since we aren't dup'ing the file, we need to explicitly clear
@@ -679,9 +680,8 @@ SetupStdFile(file, type)
*
* TclpCreateCommandChannel --
*
- * This function is called by the generic IO level to perform
- * the platform specific channel initialization for a command
- * channel.
+ * This function is called by the generic IO level to perform the
+ * platform specific channel initialization for a command channel.
*
* Results:
* Returns a new channel or NULL on failure.
@@ -699,10 +699,10 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
TclFile errorFile; /* If non-null, gives the file where errors
* can be read. */
int numPids; /* The number of pids in the pid array. */
- Tcl_Pid *pidPtr; /* An array of process identifiers.
- * Allocated by the caller, freed when
- * the channel is closed or the processes
- * are detached (in a background exec). */
+ Tcl_Pid *pidPtr; /* An array of process identifiers. Allocated
+ * by the caller, freed when the channel is
+ * closed or the processes are detached (in a
+ * background exec). */
{
char channelName[16 + TCL_INTEGER_SPACE];
int channelId;
@@ -718,15 +718,14 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
mode = 0;
if (readFile) {
- mode |= TCL_READABLE;
+ mode |= TCL_READABLE;
}
if (writeFile) {
- mode |= TCL_WRITABLE;
+ mode |= TCL_WRITABLE;
}
-
+
/*
- * Use one of the fds associated with the channel as the
- * channel id.
+ * Use one of the fds associated with the channel as the channel id.
*/
if (readFile) {
@@ -740,14 +739,14 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
}
/*
- * For backward compatibility with previous versions of Tcl, we
- * use "file%d" as the base name for pipes even though it would
- * be more natural to use "pipe%d".
+ * For backward compatibility with previous versions of Tcl, we use
+ * "file%d" as the base name for pipes even though it would be more
+ * natural to use "pipe%d".
*/
sprintf(channelName, "file%d", channelId);
statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
- (ClientData) statePtr, mode);
+ (ClientData) statePtr, mode);
return statePtr->channel;
}
@@ -757,9 +756,9 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
* TclGetAndDetachPids --
*
* This procedure is invoked in the generic implementation of a
- * background "exec" (An exec when invoked with a terminating "&")
- * to store a list of the PIDs for processes in a command pipeline
- * in the interp's result and to detach the processes.
+ * background "exec" (an exec when invoked with a terminating "&") to
+ * store a list of the PIDs for processes in a command pipeline in the
+ * interp's result and to detach the processes.
*
* Results:
* None.
@@ -772,8 +771,8 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
void
TclGetAndDetachPids(interp, chan)
- Tcl_Interp *interp;
- Tcl_Channel chan;
+ Tcl_Interp *interp; /* Interpreter to append the PIDs to. */
+ Tcl_Channel chan; /* Handle for the pipeline. */
{
PipeState *pipePtr;
Tcl_ChannelType *chanTypePtr;
@@ -786,18 +785,18 @@ TclGetAndDetachPids(interp, chan)
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
- return;
+ return;
}
pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
for (i = 0; i < pipePtr->numPids; i++) {
- TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i]));
- Tcl_AppendElement(interp, buf);
- Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
+ TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i]));
+ Tcl_AppendElement(interp, buf);
+ Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
}
if (pipePtr->numPids > 0) {
- ckfree((char *) pipePtr->pidPtr);
- pipePtr->numPids = 0;
+ ckfree((char *) pipePtr->pidPtr);
+ pipePtr->numPids = 0;
}
}
@@ -806,8 +805,8 @@ TclGetAndDetachPids(interp, chan)
*
* PipeBlockModeProc --
*
- * Helper procedure to set blocking and nonblocking modes on a
- * pipe based channel. Invoked by generic IO level code.
+ * Helper procedure to set blocking and nonblocking modes on a pipe based
+ * channel. Invoked by generic IO level code.
*
* Results:
* 0 if successful, errno when failed.
@@ -821,64 +820,64 @@ TclGetAndDetachPids(interp, chan)
/* ARGSUSED */
static int
PipeBlockModeProc(instanceData, mode)
- ClientData instanceData; /* Pipe state. */
- int mode; /* The mode to set. Can be one of
- * TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
+ ClientData instanceData; /* Pipe state. */
+ int mode; /* The mode to set. Can be one of
+ * TCL_MODE_BLOCKING or
+ * TCL_MODE_NONBLOCKING. */
{
PipeState *psPtr = (PipeState *) instanceData;
int curStatus;
int fd;
-#ifndef USE_FIONBIO
+#ifndef USE_FIONBIO
if (psPtr->inFile) {
- fd = GetFd(psPtr->inFile);
- curStatus = fcntl(fd, F_GETFL);
- if (mode == TCL_MODE_BLOCKING) {
- curStatus &= (~(O_NONBLOCK));
- } else {
- curStatus |= O_NONBLOCK;
- }
- if (fcntl(fd, F_SETFL, curStatus) < 0) {
- return errno;
- }
+ fd = GetFd(psPtr->inFile);
+ curStatus = fcntl(fd, F_GETFL);
+ if (mode == TCL_MODE_BLOCKING) {
+ curStatus &= (~(O_NONBLOCK));
+ } else {
+ curStatus |= O_NONBLOCK;
+ }
+ if (fcntl(fd, F_SETFL, curStatus) < 0) {
+ return errno;
+ }
}
if (psPtr->outFile) {
- fd = GetFd(psPtr->outFile);
- curStatus = fcntl(fd, F_GETFL);
- if (mode == TCL_MODE_BLOCKING) {
- curStatus &= (~(O_NONBLOCK));
- } else {
- curStatus |= O_NONBLOCK;
- }
- if (fcntl(fd, F_SETFL, curStatus) < 0) {
- return errno;
- }
+ fd = GetFd(psPtr->outFile);
+ curStatus = fcntl(fd, F_GETFL);
+ if (mode == TCL_MODE_BLOCKING) {
+ curStatus &= (~(O_NONBLOCK));
+ } else {
+ curStatus |= O_NONBLOCK;
+ }
+ if (fcntl(fd, F_SETFL, curStatus) < 0) {
+ return errno;
+ }
}
#endif /* !FIONBIO */
#ifdef USE_FIONBIO
if (psPtr->inFile) {
- fd = GetFd(psPtr->inFile);
- if (mode == TCL_MODE_BLOCKING) {
- curStatus = 0;
- } else {
- curStatus = 1;
- }
- if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) {
- return errno;
- }
+ fd = GetFd(psPtr->inFile);
+ if (mode == TCL_MODE_BLOCKING) {
+ curStatus = 0;
+ } else {
+ curStatus = 1;
+ }
+ if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) {
+ return errno;
+ }
}
if (psPtr->outFile != NULL) {
- fd = GetFd(psPtr->outFile);
- if (mode == TCL_MODE_BLOCKING) {
- curStatus = 0;
- } else {
- curStatus = 1;
- }
- if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) {
- return errno;
- }
+ fd = GetFd(psPtr->outFile);
+ if (mode == TCL_MODE_BLOCKING) {
+ curStatus = 0;
+ } else {
+ curStatus = 1;
+ }
+ if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) {
+ return errno;
+ }
}
#endif /* USE_FIONBIO */
@@ -893,8 +892,8 @@ PipeBlockModeProc(instanceData, mode)
* PipeCloseProc --
*
* This procedure is invoked by the generic IO level to perform
- * channel-type-specific cleanup when a command pipeline channel
- * is closed.
+ * channel-type-specific cleanup when a command pipeline channel is
+ * closed.
*
* Results:
* 0 on success, errno otherwise.
@@ -930,42 +929,40 @@ PipeCloseProc(instanceData, interp)
}
if (pipePtr->isNonBlocking || TclInExit()) {
-
/*
- * If the channel is non-blocking or Tcl is being cleaned up, just
- * detach the children PIDs, reap them (important if we are in a
- * dynamic load module), and discard the errorFile.
- */
-
- Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
- Tcl_ReapDetachedProcs();
-
- if (pipePtr->errorFile) {
+ * If the channel is non-blocking or Tcl is being cleaned up, just
+ * detach the children PIDs, reap them (important if we are in a
+ * dynamic load module), and discard the errorFile.
+ */
+
+ Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
+ Tcl_ReapDetachedProcs();
+
+ if (pipePtr->errorFile) {
TclpCloseFile(pipePtr->errorFile);
- }
+ }
} else {
-
/*
- * Wrap the error file into a channel and give it to the cleanup
- * routine.
- */
+ * Wrap the error file into a channel and give it to the cleanup
+ * routine.
+ */
- if (pipePtr->errorFile) {
+ if (pipePtr->errorFile) {
errChan = Tcl_MakeFileChannel(
(ClientData) GetFd(pipePtr->errorFile), TCL_READABLE);
- } else {
- errChan = NULL;
- }
- result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
- errChan);
+ } else {
+ errChan = NULL;
+ }
+ result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
+ errChan);
}
if (pipePtr->numPids != 0) {
- ckfree((char *) pipePtr->pidPtr);
+ ckfree((char *) pipePtr->pidPtr);
}
ckfree((char *) pipePtr);
if (errorCode == 0) {
- return result;
+ return result;
}
return errorCode;
}
@@ -975,8 +972,8 @@ PipeCloseProc(instanceData, interp)
*
* PipeInputProc --
*
- * This procedure is invoked from the generic IO level to read
- * input from a command pipeline based channel.
+ * This procedure is invoked from the generic IO level to read input from
+ * a command pipeline based channel.
*
* Results:
* The number of bytes read is returned or -1 on error. An output
@@ -990,29 +987,28 @@ PipeCloseProc(instanceData, interp)
static int
PipeInputProc(instanceData, buf, toRead, errorCodePtr)
- ClientData instanceData; /* Pipe state. */
- char *buf; /* Where to store data read. */
- int toRead; /* How much space is available
- * in the buffer? */
- int *errorCodePtr; /* Where to store error code. */
+ ClientData instanceData; /* Pipe state. */
+ char *buf; /* Where to store data read. */
+ int toRead; /* How much space is available in the
+ * buffer? */
+ int *errorCodePtr; /* Where to store error code. */
{
PipeState *psPtr = (PipeState *) instanceData;
- int bytesRead; /* How many bytes were actually
- * read from the input device? */
+ int bytesRead; /* How many bytes were actually read from the
+ * input device? */
*errorCodePtr = 0;
-
+
/*
* Assume there is always enough input available. This will block
* appropriately, and read will unblock as soon as a short read is
* possible, if the channel is in blocking mode. If the channel is
- * nonblocking, the read will never block.
- * Some OSes can throw an interrupt error, for which we should
- * immediately retry. [Bug #415131]
+ * nonblocking, the read will never block. Some OSes can throw an
+ * interrupt error, for which we should immediately retry. [Bug #415131]
*/
do {
- bytesRead = read (GetFd(psPtr->inFile), buf, (size_t) toRead);
+ bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead);
} while ((bytesRead < 0) && (errno == EINTR));
if (bytesRead < 0) {
@@ -1028,13 +1024,12 @@ PipeInputProc(instanceData, buf, toRead, errorCodePtr)
*
* PipeOutputProc--
*
- * This procedure is invoked from the generic IO level to write
- * output to a command pipeline based channel.
+ * This procedure is invoked from the generic IO level to write output to
+ * a command pipeline based channel.
*
* Results:
- * The number of bytes written is returned or -1 on error. An
- * output argument contains a POSIX error code if an error occurred,
- * or zero.
+ * The number of bytes written is returned or -1 on error. An output
+ * argument contains a POSIX error code if an error occurred, or zero.
*
* Side effects:
* Writes output on the output device of the channel.
@@ -1044,10 +1039,10 @@ PipeInputProc(instanceData, buf, toRead, errorCodePtr)
static int
PipeOutputProc(instanceData, buf, toWrite, errorCodePtr)
- ClientData instanceData; /* Pipe state. */
- CONST char *buf; /* The data buffer. */
- int toWrite; /* How many bytes to write? */
- int *errorCodePtr; /* Where to store error code. */
+ ClientData instanceData; /* Pipe state. */
+ CONST char *buf; /* The data buffer. */
+ int toWrite; /* How many bytes to write? */
+ int *errorCodePtr; /* Where to store error code. */
{
PipeState *psPtr = (PipeState *) instanceData;
int written;
@@ -1055,8 +1050,8 @@ PipeOutputProc(instanceData, buf, toWrite, errorCodePtr)
*errorCodePtr = 0;
/*
- * Some OSes can throw an interrupt error, for which we should
- * immediately retry. [Bug #415131]
+ * Some OSes can throw an interrupt error, for which we should immediately
+ * retry. [Bug #415131]
*/
do {
@@ -1082,18 +1077,18 @@ PipeOutputProc(instanceData, buf, toWrite, errorCodePtr)
* None.
*
* Side effects:
- * Sets up the notifier so that a future event on the channel will
- * be seen by Tcl.
+ * Sets up the notifier so that a future event on the channel will be
+ * seen by Tcl.
*
*----------------------------------------------------------------------
*/
static void
PipeWatchProc(instanceData, mask)
- ClientData instanceData; /* The pipe state. */
- int mask; /* Events of interest; an OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABEL and TCL_EXCEPTION. */
+ ClientData instanceData; /* The pipe state. */
+ int mask; /* Events of interest; an OR-ed combination of
+ * TCL_READABLE, TCL_WRITABLE and
+ * TCL_EXCEPTION. */
{
PipeState *psPtr = (PipeState *) instanceData;
int newmask;
@@ -1125,12 +1120,12 @@ PipeWatchProc(instanceData, mask)
*
* PipeGetHandleProc --
*
- * Called from Tcl_GetChannelHandle to retrieve OS handles from
- * inside a command pipeline based channel.
+ * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
+ * command pipeline based channel.
*
* Results:
- * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
- * there is no handle for the specified direction.
+ * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
+ * handle for the specified direction.
*
* Side effects:
* None.
@@ -1196,8 +1191,8 @@ Tcl_WaitPid(pid, statPtr, options)
*
* Tcl_PidObjCmd --
*
- * This procedure is invoked to process the "pid" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "pid" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -1216,12 +1211,6 @@ Tcl_PidObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST *objv; /* Argument strings. */
{
- Tcl_Channel chan;
- Tcl_ChannelType *chanTypePtr;
- PipeState *pipePtr;
- int i;
- Tcl_Obj *resultPtr, *longObjPtr;
-
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
@@ -1229,17 +1218,23 @@ Tcl_PidObjCmd(dummy, interp, objc, objv)
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid()));
} else {
- chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
- if (chan == (Tcl_Channel) NULL) {
+ Tcl_Channel chan;
+ Tcl_ChannelType *chanTypePtr;
+ PipeState *pipePtr;
+ int i;
+ Tcl_Obj *resultPtr, *longObjPtr;
+
+ chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
+ if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return TCL_OK;
}
- pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
+ pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
- for (i = 0; i < pipePtr->numPids; i++) {
+ for (i = 0; i < pipePtr->numPids; i++) {
longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
}
@@ -1258,7 +1253,8 @@ Tcl_PidObjCmd(dummy, interp, objc, objv)
* Results:
* None.
*
- * This procedure carries out no operation on Unix.
+ * Notes:
+ * This procedure carries out no operation on Unix.
*
*----------------------------------------------------------------------
*/
@@ -1267,4 +1263,11 @@ void
TclpFinalizePipes()
{
}
-
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c
index 0d13d15..05b854e 100644
--- a/unix/tclXtNotify.c
+++ b/unix/tclXtNotify.c
@@ -1,31 +1,32 @@
-/*
+/*
* tclXtNotify.c --
*
- * This file contains the notifier driver implementation for the
- * Xt intrinsics.
+ * This file contains the notifier driver implementation for the Xt
+ * intrinsics.
*
* 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: tclXtNotify.c,v 1.6 2004/04/06 22:25:57 dgp Exp $
+ * RCS: @(#) $Id: tclXtNotify.c,v 1.7 2005/07/24 22:56:45 dkf Exp $
*/
#include <X11/Intrinsic.h>
#include "tclInt.h"
/*
- * This structure is used to keep track of the notifier info for a
- * a registered file.
+ * This structure is used to keep track of the notifier info for a a
+ * registered file.
*/
typedef struct FileHandler {
int fd;
- int mask; /* Mask of desired events: TCL_READABLE, etc. */
- int readyMask; /* Events that have been seen since the
- last time FileHandlerEventProc was called
- for this file. */
+ int mask; /* Mask of desired events: TCL_READABLE,
+ * etc. */
+ int readyMask; /* Events that have been seen since the last
+ * time FileHandlerEventProc was called for
+ * this file. */
XtInputId read; /* Xt read callback handle. */
XtInputId write; /* Xt write callback handle. */
XtInputId except; /* Xt exception callback handle. */
@@ -36,33 +37,32 @@ typedef struct FileHandler {
} FileHandler;
/*
- * The following structure is what is added to the Tcl event queue when
- * file handlers are ready to fire.
+ * The following structure is what is added to the Tcl event queue when file
+ * handlers are ready to fire.
*/
typedef struct FileHandlerEvent {
- Tcl_Event header; /* Information that is standard for
- * all events. */
- int fd; /* File descriptor that is ready. Used
- * to find the FileHandler structure for
- * the file (can't point directly to the
- * FileHandler structure because it could
- * go away while the event is queued). */
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ int fd; /* File descriptor that is ready. Used to find
+ * the FileHandler structure for the file
+ * (can't point directly to the FileHandler
+ * structure because it could go away while
+ * the event is queued). */
} FileHandlerEvent;
/*
- * The following static structure contains the state information for the
- * Xt based implementation of the Tcl notifier.
+ * The following static structure contains the state information for the Xt
+ * based implementation of the Tcl notifier.
*/
static struct NotifierState {
- XtAppContext appContext; /* The context used by the Xt
- * notifier. Can be set with
- * TclSetAppContext. */
- int appContextCreated; /* Was it created by us? */
- XtIntervalId currentTimeout; /* Handle of current timer. */
- FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler
- * list. */
+ XtAppContext appContext; /* The context used by the Xt notifier. Can be
+ * set with TclSetAppContext. */
+ int appContextCreated; /* Was it created by us? */
+ XtIntervalId currentTimeout;/* Handle of current timer. */
+ FileHandler *firstFileHandlerPtr;
+ /* Pointer to head of file handler list. */
} notifier;
/*
@@ -84,7 +84,7 @@ static void NotifierExitHandler _ANSI_ARGS_((
ClientData clientData));
static void TimerProc _ANSI_ARGS_((caddr_t clientData,
XtIntervalId *id));
-static void CreateFileHandler _ANSI_ARGS_((int fd, int mask,
+static void CreateFileHandler _ANSI_ARGS_((int fd, int mask,
Tcl_FileProc * proc, ClientData clientData));
static void DeleteFileHandler _ANSI_ARGS_((int fd));
static void SetTimer _ANSI_ARGS_((Tcl_Time * timePtr));
@@ -107,18 +107,18 @@ EXTERN XtAppContext TclSetAppContext _ANSI_ARGS_((XtAppContext ctx));
* None.
*
* Side effects:
- * Sets the application context used by the notifier. Panics if
- * the context is already set when called.
+ * Sets the application context used by the notifier. Panics if the
+ * context is already set when called.
*
*----------------------------------------------------------------------
*/
XtAppContext
TclSetAppContext(appContext)
- XtAppContext appContext;
+ XtAppContext appContext;
{
if (!initialized) {
- InitNotifier();
+ InitNotifier();
}
/*
@@ -126,46 +126,41 @@ TclSetAppContext(appContext)
* new context. If so, we panic because we try to prevent switching
* contexts by mistake. Otherwise, we return the one we have.
*/
-
- if (notifier.appContext != NULL) {
- if (appContext != NULL) {
+ if (notifier.appContext != NULL) {
+ if (appContext != NULL) {
/*
- * We already have a context. We do not allow switching contexts
- * after initialization, so we panic.
- */
-
- Tcl_Panic("TclSetAppContext: multiple application contexts");
+ * We already have a context. We do not allow switching contexts
+ * after initialization, so we panic.
+ */
- }
+ Tcl_Panic("TclSetAppContext: multiple application contexts");
+ }
} else {
+ /*
+ * If we get here we have not yet gotten a context, so either create
+ * one or use the one supplied by our caller.
+ */
- /*
- * If we get here we have not yet gotten a context, so either create
- * one or use the one supplied by our caller.
- */
-
- if (appContext == NULL) {
-
+ if (appContext == NULL) {
/*
- * We must create a new context and tell our caller what it is, so
- * she can use it too.
- */
-
- notifier.appContext = XtCreateApplicationContext();
- notifier.appContextCreated = 1;
- } else {
+ * We must create a new context and tell our caller what it is, so
+ * she can use it too.
+ */
+ notifier.appContext = XtCreateApplicationContext();
+ notifier.appContextCreated = 1;
+ } else {
/*
- * Otherwise we remember the context that our caller gave us
- * and use it.
- */
-
- notifier.appContextCreated = 0;
- notifier.appContext = appContext;
- }
+ * Otherwise we remember the context that our caller gave us and
+ * use it.
+ */
+
+ notifier.appContextCreated = 0;
+ notifier.appContext = appContext;
+ }
}
-
+
return notifier.appContext;
}
@@ -189,14 +184,15 @@ void
InitNotifier()
{
Tcl_NotifierProcs notifier;
+
/*
- * Only reinitialize if we are not in exit handling. The notifier
- * can get reinitialized after its own exit handler has run, because
- * of exit handlers for the I/O and timer sub-systems (order dependency).
+ * Only reinitialize if we are not in exit handling. The notifier can get
+ * reinitialized after its own exit handler has run, because of exit
+ * handlers for the I/O and timer sub-systems (order dependency).
*/
if (TclInExit()) {
- return;
+ return;
}
notifier.createFileHandlerProc = CreateFileHandler;
@@ -209,7 +205,7 @@ InitNotifier()
* DO NOT create the application context yet; doing so would prevent
* external applications from setting it for us to their own ones.
*/
-
+
initialized = 1;
memset(&notifier, 0, sizeof(notifier));
Tcl_CreateExitHandler(NotifierExitHandler, NULL);
@@ -220,8 +216,8 @@ InitNotifier()
*
* NotifierExitHandler --
*
- * This function is called to cleanup the notifier state before
- * Tcl is unloaded.
+ * This function is called to cleanup the notifier state before Tcl is
+ * unloaded.
*
* Results:
* None.
@@ -237,15 +233,15 @@ NotifierExitHandler(
ClientData clientData) /* Not used. */
{
if (notifier.currentTimeout != 0) {
- XtRemoveTimeOut(notifier.currentTimeout);
+ XtRemoveTimeOut(notifier.currentTimeout);
}
for (; notifier.firstFileHandlerPtr != NULL; ) {
- Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
+ Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
}
if (notifier.appContextCreated) {
- XtDestroyApplicationContext(notifier.appContext);
- notifier.appContextCreated = 0;
- notifier.appContext = NULL;
+ XtDestroyApplicationContext(notifier.appContext);
+ notifier.appContextCreated = 0;
+ notifier.appContext = NULL;
}
initialized = 0;
}
@@ -282,9 +278,8 @@ SetTimer(timePtr)
}
if (timePtr) {
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
- notifier.currentTimeout =
- XtAppAddTimeOut(notifier.appContext, (unsigned long) timeout,
- TimerProc, NULL);
+ notifier.currentTimeout = XtAppAddTimeOut(notifier.appContext,
+ (unsigned long) timeout, TimerProc, NULL);
} else {
notifier.currentTimeout = 0;
}
@@ -295,14 +290,13 @@ SetTimer(timePtr)
*
* TimerProc --
*
- * This procedure is the XtTimerCallbackProc used to handle
- * timeouts.
+ * This procedure is the XtTimerCallbackProc used to handle timeouts.
*
* Results:
* None.
*
* Side effects:
- * Processes all queued events.
+ * Processes all queued events.
*
*----------------------------------------------------------------------
*/
@@ -331,8 +325,8 @@ TimerProc(data, id)
* None.
*
* Side effects:
- * Creates a new file handler structure and registers one or more
- * input procedures with Xt.
+ * Creates a new file handler structure and registers one or more input
+ * procedures with Xt.
*
*----------------------------------------------------------------------
*/
@@ -341,11 +335,11 @@ static void
CreateFileHandler(fd, mask, proc, clientData)
int fd; /* Handle of stream to watch. */
int mask; /* OR'ed combination of TCL_READABLE,
- * TCL_WRITABLE, and TCL_EXCEPTION:
- * indicates conditions under which
- * proc should be called. */
- Tcl_FileProc *proc; /* Procedure to call for each
- * selected event. */
+ * TCL_WRITABLE, and TCL_EXCEPTION: indicates
+ * conditions under which proc should be
+ * called. */
+ Tcl_FileProc *proc; /* Procedure to call for each selected
+ * event. */
ClientData clientData; /* Arbitrary data to pass to proc. */
{
FileHandler *filePtr;
@@ -382,9 +376,8 @@ CreateFileHandler(fd, mask, proc, clientData)
if (mask & TCL_READABLE) {
if (!(filePtr->mask & TCL_READABLE)) {
- filePtr->read =
- XtAppAddInput(notifier.appContext, fd, XtInputReadMask,
- FileProc, filePtr);
+ filePtr->read = XtAppAddInput(notifier.appContext, fd,
+ XtInputReadMask, FileProc, filePtr);
}
} else {
if (filePtr->mask & TCL_READABLE) {
@@ -393,9 +386,8 @@ CreateFileHandler(fd, mask, proc, clientData)
}
if (mask & TCL_WRITABLE) {
if (!(filePtr->mask & TCL_WRITABLE)) {
- filePtr->write =
- XtAppAddInput(notifier.appContext, fd, XtInputWriteMask,
- FileProc, filePtr);
+ filePtr->write = XtAppAddInput(notifier.appContext, fd,
+ XtInputWriteMask, FileProc, filePtr);
}
} else {
if (filePtr->mask & TCL_WRITABLE) {
@@ -404,9 +396,8 @@ CreateFileHandler(fd, mask, proc, clientData)
}
if (mask & TCL_EXCEPTION) {
if (!(filePtr->mask & TCL_EXCEPTION)) {
- filePtr->except =
- XtAppAddInput(notifier.appContext, fd, XtInputExceptMask,
- FileProc, filePtr);
+ filePtr->except = XtAppAddInput(notifier.appContext, fd,
+ XtInputExceptMask, FileProc, filePtr);
}
} else {
if (filePtr->mask & TCL_EXCEPTION) {
@@ -421,8 +412,7 @@ CreateFileHandler(fd, mask, proc, clientData)
*
* DeleteFileHandler --
*
- * Cancel a previously-arranged callback arrangement for
- * a file.
+ * Cancel a previously-arranged callback arrangement for a file.
*
* Results:
* None.
@@ -435,8 +425,8 @@ CreateFileHandler(fd, mask, proc, clientData)
static void
DeleteFileHandler(fd)
- int fd; /* Stream id for which to remove
- * callback procedure. */
+ int fd; /* Stream id for which to remove callback
+ * procedure. */
{
FileHandler *filePtr, *prevPtr;
@@ -447,8 +437,7 @@ DeleteFileHandler(fd)
TclSetAppContext(NULL);
/*
- * Find the entry for the given file (and return if there
- * isn't one).
+ * Find the entry for the given file (and return if there isn't one).
*/
for (prevPtr = NULL, filePtr = notifier.firstFileHandlerPtr; ;
@@ -494,8 +483,7 @@ DeleteFileHandler(fd)
* None.
*
* Side effects:
- * Makes an entry on the Tcl event queue if the event is
- * interesting.
+ * Makes an entry on the Tcl event queue if the event is interesting.
*
*----------------------------------------------------------------------
*/
@@ -529,7 +517,7 @@ FileProc(clientData, fd, id)
if (!(filePtr->mask & mask) || (filePtr->readyMask & mask)) {
return;
}
-
+
/*
* This is an interesting event, so put it onto the event queue.
*/
@@ -552,16 +540,16 @@ FileProc(clientData, fd, id)
*
* FileHandlerEventProc --
*
- * This procedure is called by Tcl_ServiceEvent when a file event
- * reaches the front of the event queue. This procedure is
- * responsible for actually handling the event by invoking the
- * callback for the file handler.
+ * This procedure is called by Tcl_ServiceEvent when a file event reaches
+ * the front of the event queue. This procedure is responsible for
+ * actually handling the event by invoking the callback for the file
+ * handler.
*
* 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_FILE_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_FILE_EVENTS flag bit isn't set.
*
* Side effects:
* Whatever the file handler's callback procedure does.
@@ -572,8 +560,8 @@ FileProc(clientData, fd, id)
static int
FileHandlerEventProc(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. */
{
FileHandler *filePtr;
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
@@ -585,9 +573,9 @@ FileHandlerEventProc(evPtr, flags)
/*
* Search through the file handlers to find the one whose handle matches
- * the event. We do this rather than keeping a pointer to the file
- * handler directly in the event, so that the handler can be deleted
- * while the event is queued without leaving a dangling pointer.
+ * the event. We do this rather than keeping a pointer to the file handler
+ * directly in the event, so that the handler can be deleted while the
+ * event is queued without leaving a dangling pointer.
*/
for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
@@ -598,14 +586,14 @@ FileHandlerEventProc(evPtr, flags)
/*
* The code is tricky for two reasons:
- * 1. The file handler's desired events could have changed
- * since the time when the event was queued, so AND the
- * ready mask with the desired mask.
- * 2. The file could have been closed and re-opened since
- * the time when the event was queued. This is why the
- * ready mask is stored in the file handler rather than
- * the queued event: it will be zeroed when a new
- * file handler is created for the newly opened file.
+ * 1. The file handler's desired events could have changed since the
+ * time when the event was queued, so AND the ready mask with the
+ * desired mask.
+ * 2. The file could have been closed and re-opened since the time
+ * when the event was queued. This is why the ready mask is stored
+ * in the file handler rather than the queued event: it will be
+ * zeroed when a new file handler is created for the newly opened
+ * file.
*/
mask = filePtr->readyMask & filePtr->mask;
@@ -623,14 +611,14 @@ FileHandlerEventProc(evPtr, flags)
*
* WaitForEvent --
*
- * This function is called by Tcl_DoOneEvent to wait for new
- * events on the message queue. If the block time is 0, then
- * Tcl_WaitForEvent just polls without blocking.
+ * This function is called by Tcl_DoOneEvent to wait for new events on
+ * the message queue. If the block time is 0, then Tcl_WaitForEvent just
+ * polls without blocking.
*
* Results:
- * Returns 1 if an event was found, else 0. This ensures that
- * Tcl_DoOneEvent will return 1, even if the event is handled
- * by non-Tcl code.
+ * Returns 1 if an event was found, else 0. This ensures that
+ * Tcl_DoOneEvent will return 1, even if the event is handled by non-Tcl
+ * code.
*
* Side effects:
* Queues file events that are detected by the select.
@@ -651,18 +639,27 @@ WaitForEvent(
TclSetAppContext(NULL);
if (timePtr) {
- timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
- if (timeout == 0) {
- if (XtAppPending(notifier.appContext)) {
- goto process;
- } else {
- return 0;
- }
- } else {
- Tcl_SetTimer(timePtr);
- }
+ timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
+ if (timeout == 0) {
+ if (XtAppPending(notifier.appContext)) {
+ goto process;
+ } else {
+ return 0;
+ }
+ } else {
+ Tcl_SetTimer(timePtr);
+ }
}
-process:
+
+ process:
XtAppProcessEvent(notifier.appContext, XtIMAll);
return 1;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclAppInit.c b/win/tclAppInit.c
index b7bcc30..6b20dce 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -2,16 +2,16 @@
* tclAppInit.c --
*
* Provides a default version of the main program and Tcl_AppInit
- * procedure for Tcl applications (without Tk). Note that this
- * program must be built in Win32 console mode to work properly.
+ * function for Tcl applications (without Tk). Note that this program
+ * must be built in Win32 console mode to work properly.
*
* Copyright (c) 1996-1997 by Sun Microsystems, Inc.
* Copyright (c) 1998-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: tclAppInit.c,v 1.21 2004/10/28 04:53:42 davygrvy Exp $
+ * RCS: @(#) $Id: tclAppInit.c,v 1.22 2005/07/24 22:56:45 dkf Exp $
*/
#include "tcl.h"
@@ -26,14 +26,14 @@ extern Tcl_PackageInitProc TclObjTest_Init;
#endif /* TCL_TEST */
#if defined(__GNUC__)
-static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));
+static void setargv(int *argcPtr, char ***argvPtr);
#endif /* __GNUC__ */
-static BOOL WINAPI sigHandler (DWORD fdwCtrlType);
+static BOOL WINAPI sigHandler(DWORD fdwCtrlType);
static Tcl_AsyncProc asyncExit;
static void AppInitExitHandler(ClientData clientData);
static Tcl_AsyncHandler exitToken = NULL;
-static DWORD exitErrorCode = 0;
+static DWORD exitErrorCode = 0;
/*
@@ -44,8 +44,8 @@ static DWORD exitErrorCode = 0;
* This is the main program for the application.
*
* Results:
- * None: Tcl_Main never returns here, so this procedure never
- * returns either.
+ * None: Tcl_Main never returns here, so this function never returns
+ * either.
*
* Side effects:
* Whatever the application does.
@@ -54,13 +54,13 @@ static DWORD exitErrorCode = 0;
*/
int
-main (int argc, char *argv[])
+main(int argc, char *argv[])
{
/*
- * The following #if block allows you to change the AppInit
- * function by using a #define of TCL_LOCAL_APPINIT instead
- * of rewriting this entire file. The #if checks for that
- * #define and uses Tcl_AppInit if it doesn't exist.
+ * The following #if block allows you to change the AppInit function by
+ * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire
+ * file. The #if checks for that #define and uses Tcl_AppInit if it
+ * doesn't exist.
*/
#ifndef TCL_LOCAL_APPINIT
@@ -81,8 +81,8 @@ main (int argc, char *argv[])
char *p;
/*
- * Set up the default locale to be standard "C" locale so parsing
- * is performed correctly.
+ * Set up the default locale to be standard "C" locale so parsing is
+ * performed correctly.
*/
#if defined(__GNUC__)
@@ -114,13 +114,13 @@ main (int argc, char *argv[])
*
* Tcl_AppInit --
*
- * This procedure performs application-specific initialization.
- * Most applications, especially those that incorporate additional
- * packages, will have their own version of this procedure.
+ * This function performs application-specific initialization. Most
+ * applications, especially those that incorporate additional packages,
+ * will have their own version of this function.
*
* Results:
- * Returns a standard Tcl completion code, and leaves an error
- * message in the interp's result if an error occurs.
+ * Returns a standard Tcl completion code, and leaves an error message in
+ * the interp's result if an error occurs.
*
* Side effects:
* Depends on the startup script.
@@ -139,13 +139,15 @@ Tcl_AppInit(interp)
/*
* Install a signal handler to the win32 console tclsh is running in.
*/
+
SetConsoleCtrlHandler(sigHandler, TRUE);
exitToken = Tcl_AsyncCreate(asyncExit, NULL);
/*
- * This exit handler will be used to free the
- * resources allocated in this file.
+ * This exit handler will be used to free the resources allocated in this
+ * file.
*/
+
Tcl_CreateExitHandler(AppInitExitHandler, NULL);
#ifdef TCL_TEST
@@ -160,7 +162,7 @@ Tcl_AppInit(interp)
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
- Procbodytest_SafeInit);
+ Procbodytest_SafeInit);
#endif /* TCL_TEST */
#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES
@@ -182,8 +184,8 @@ Tcl_AppInit(interp)
#endif
/*
- * Call the init procedures for included packages. Each call should
- * look like this:
+ * Call the init functions for included packages. Each call should look
+ * like this:
*
* if (Mod_Init(interp) == TCL_ERROR) {
* return TCL_ERROR;
@@ -193,15 +195,15 @@ Tcl_AppInit(interp)
*/
/*
- * Call Tcl_CreateCommand for application-specific commands, if
- * they weren't already created by the init procedures called above.
+ * Call Tcl_CreateCommand for application-specific commands, if they
+ * weren't already created by the init functions called above.
*/
/*
- * Specify a user-specific startup file to invoke if the application
- * is run interactively. Typically the startup file is "~/.apprc"
- * where "app" is the name of the application. If this line is deleted
- * then no user-specific startup file will be run under any conditions.
+ * Specify a user-specific startup file to invoke if the application is
+ * run interactively. Typically the startup file is "~/.apprc" where "app"
+ * is the name of the application. If this line is deleted then no
+ * user-specific startup file will be run under any conditions.
*/
Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
@@ -213,8 +215,8 @@ Tcl_AppInit(interp)
*
* AppInitExitHandler --
*
- * This function is called to cleanup the app init resources before
- * Tcl is unloaded.
+ * This function is called to cleanup the app init resources before Tcl
+ * is unloaded.
*
* Results:
* None.
@@ -230,12 +232,13 @@ AppInitExitHandler(
ClientData clientData) /* Not Used. */
{
if (exitToken != NULL) {
- /*
- * This should be safe to do even if we
- * are in an async exit right now.
- */
- Tcl_AsyncDelete(exitToken);
- exitToken = NULL;
+ /*
+ * This should be safe to do even if we are in an async exit right
+ * now.
+ */
+
+ Tcl_AsyncDelete(exitToken);
+ exitToken = NULL;
}
}
@@ -244,10 +247,10 @@ AppInitExitHandler(
*
* setargv --
*
- * Parse the Windows command line string into argc/argv. Done here
- * because we don't trust the builtin argument parser in crt0.
- * Windows applications are responsible for breaking their command
- * line into arguments.
+ * Parse the Windows command line string into argc/argv. Done here
+ * because we don't trust the builtin argument parser in crt0. Windows
+ * applications are responsible for breaking their command line into
+ * arguments.
*
* 2N backslashes + quote -> N backslashes + begin quoted string
* 2N + 1 backslashes + quote -> literal
@@ -257,8 +260,8 @@ AppInitExitHandler(
* quote -> begin quoted string
*
* Results:
- * Fills argcPtr with the number of arguments and argvPtr with the
- * array of arguments.
+ * Fills argcPtr with the number of arguments and argvPtr with the array
+ * of arguments.
*
* Side effects:
* Memory allocated.
@@ -279,8 +282,8 @@ setargv(argcPtr, argvPtr)
cmdLine = GetCommandLine(); /* INTL: BUG */
/*
- * Precompute an overly pessimistic guess at the number of arguments
- * in the command line by counting non-space spans.
+ * Precompute an overly pessimistic guess at the number of arguments in
+ * the command line by counting non-space spans.
*/
size = 2;
@@ -328,18 +331,18 @@ setargv(argcPtr, argvPtr)
} else {
inquote = !inquote;
}
- }
- slashes >>= 1;
- }
+ }
+ slashes >>= 1;
+ }
- while (slashes) {
+ while (slashes) {
*arg = '\\';
arg++;
slashes--;
}
- if ((*p == '\0')
- || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
+ if ((*p == '\0') || (!inquote &&
+ ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
break;
}
if (copy != 0) {
@@ -347,7 +350,7 @@ setargv(argcPtr, argvPtr)
arg++;
}
p++;
- }
+ }
*arg = '\0';
argSpace = arg + 1;
}
@@ -375,7 +378,7 @@ setargv(argcPtr, argvPtr)
*/
int
-asyncExit (
+asyncExit(
ClientData clientData, /* Not Used. */
Tcl_Interp *interp, /* interp in context, if any. */
int code) /* result of last command, if any. */
@@ -391,17 +394,17 @@ asyncExit (
*
* sigHandler --
*
- * Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and
- * other exits. This is needed so tclsh can do it's real clean-up
- * and not an unclean crash terminate.
+ * Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and other
+ * exits. This is needed so tclsh can do it's real clean-up and not an
+ * unclean crash terminate.
*
* Results:
* TRUE.
*
* Side effects:
- * Effects the way the app exits from a signal. This is an
- * operating system supplied thread and unsafe to call ANY
- * Tcl commands except for Tcl_AsyncMark.
+ * Effects the way the app exits from a signal. This is an operating
+ * system supplied thread and unsafe to call ANY Tcl commands except for
+ * Tcl_AsyncMark.
*
*----------------------------------------------------------------------
*/
@@ -413,28 +416,42 @@ sigHandler(
HANDLE hStdIn;
if (!exitToken) {
- /* Async token must have been destroyed, punt gracefully. */
+ /*
+ * Async token must have been destroyed, punt gracefully.
+ */
return FALSE;
}
/*
- * If Tcl is currently executing some bytecode or in the eventloop,
- * this will cause Tcl to enter asyncExit at the next command
- * boundry.
+ * If Tcl is currently executing some bytecode or in the eventloop, this
+ * will cause Tcl to enter asyncExit at the next command boundry.
*/
+
exitErrorCode = fdwCtrlType;
Tcl_AsyncMark(exitToken);
/*
- * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF>
- * should it be blocked on input and our Tcl_AsyncMark didn't grab
- * the attention of the interpreter.
+ * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF> should
+ * it be blocked on input and our Tcl_AsyncMark didn't grab the attention
+ * of the interpreter.
*/
+
hStdIn = GetStdHandle(STD_INPUT_HANDLE);
if (hStdIn) {
CloseHandle(hStdIn);
}
- /* indicate to the OS not to call the default terminator. */
+ /*
+ * Indicate to the OS not to call the default terminator.
+ */
+
return TRUE;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index 0fe1b52..ce54eee 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -1,22 +1,23 @@
/*
* tclWin32Dll.c --
*
- * This file contains the DLL entry point.
+ * This file contains the DLL entry point and other low-level bit bashing
+ * code that needs inline assembly.
*
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 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: tclWin32Dll.c,v 1.45 2005/06/06 20:54:18 kennykb Exp $
+ * RCS: @(#) $Id: tclWin32Dll.c,v 1.46 2005/07/24 22:56:46 dkf Exp $
*/
#include "tclWinInt.h"
/*
- * The following data structures are used when loading the thunking
- * library for execing child processes under Win32s.
+ * The following data structures are used when loading the thunking library
+ * for execing child processes under Win32s.
*/
typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
@@ -29,40 +30,37 @@ typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule);
/*
- * The following variables keep track of information about this DLL
- * on a per-instance basis. Each time this DLL is loaded, it gets its own
- * new data segment with its own copy of all static and global information.
+ * The following variables keep track of information about this DLL on a
+ * per-instance basis. Each time this DLL is loaded, it gets its own new data
+ * segment with its own copy of all static and global information.
*/
static HINSTANCE hInstance; /* HINSTANCE of this DLL. */
static int platformId; /* Running under NT, or 95/98? */
#ifdef HAVE_NO_SEH
-
/*
- * Unlike Borland and Microsoft, we don't register exception handlers
- * by pushing registration records onto the runtime stack. Instead, we
- * register them by creating an EXCEPTION_REGISTRATION within the activation
- * record.
+ * Unlike Borland and Microsoft, we don't register exception handlers by
+ * pushing registration records onto the runtime stack. Instead, we register
+ * them by creating an EXCEPTION_REGISTRATION within the activation record.
*/
typedef struct EXCEPTION_REGISTRATION {
- struct EXCEPTION_REGISTRATION* link;
- EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*,
- struct _CONTEXT*, void* );
- void* ebp;
- void* esp;
+ struct EXCEPTION_REGISTRATION *link;
+ EXCEPTION_DISPOSITION (*handler)(
+ struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*);
+ void *ebp;
+ void *esp;
int status;
} EXCEPTION_REGISTRATION;
-
#endif
/*
- * VC++ 5.x has no 'cpuid' assembler instruction, so we
- * must emulate it
+ * VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it
*/
-#if defined(_MSC_VER) && ( _MSC_VER <= 1100 )
-#define cpuid __asm __emit 0fh __asm __emit 0a2h
+
+#if defined(_MSC_VER) && (_MSC_VER <= 1100)
+#define cpuid __asm __emit 0fh __asm __emit 0a2h
#endif
/*
@@ -106,13 +104,15 @@ static TclWinProcs asciiProcs = {
WCHAR *, TCHAR **)) SearchPathA,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
+
/*
* The three NULL function pointers will only be set when
- * Tcl_FindExecutable is called. If you don't ever call that
- * function, the application will crash whenever WinTcl tries to call
- * functions through these null pointers. That is not a bug in Tcl
- * -- Tcl_FindExecutable is obligatory in recent Tcl releases.
+ * Tcl_FindExecutable is called. If you don't ever call that function, the
+ * application will crash whenever WinTcl tries to call functions through
+ * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is
+ * mandatory in recent Tcl releases.
*/
+
NULL,
NULL,
/* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _utime, */
@@ -157,13 +157,15 @@ static TclWinProcs unicodeProcs = {
WCHAR *, TCHAR **)) SearchPathW,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,
+
/*
* The three NULL function pointers will only be set when
- * Tcl_FindExecutable is called. If you don't ever call that
- * function, the application will crash whenever WinTcl tries to call
- * functions through these null pointers. That is not a bug in Tcl
- * -- Tcl_FindExecutable is obligatory in recent Tcl releases.
+ * Tcl_FindExecutable is called. If you don't ever call that function, the
+ * application will crash whenever WinTcl tries to call functions through
+ * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is
+ * mandatory in recent Tcl releases.
*/
+
NULL,
NULL,
/* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _wutime, */
@@ -176,64 +178,63 @@ static TclWinProcs unicodeProcs = {
TclWinProcs *tclWinProcs;
static Tcl_Encoding tclWinTCharEncoding;
-
#ifdef HAVE_NO_SEH
-
-/* Need to add noinline flag to DllMain declaration so that gcc -O3
- * does not inline asm code into DllEntryPoint and cause a
- * compile time error because of redefined local labels.
+/*
+ * Need to add noinline flag to DllMain declaration so that gcc -O3 does not
+ * inline asm code into DllEntryPoint and cause a compile time error because
+ * of redefined local labels.
*/
BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
- LPVOID reserved)
- __attribute__ ((noinline));
-
+ LPVOID reserved) __attribute__ ((noinline));
#else
-
/*
* The following declaration is for the VC++ DLL entry point.
*/
BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
- LPVOID reserved);
+ LPVOID reserved);
#endif /* HAVE_NO_SEH */
-
/*
* The following structure and linked list is to allow us to map between
- * volume mount points and drive letters on the fly (no Win API exists
- * for this).
+ * volume mount points and drive letters on the fly (no Win API exists for
+ * this).
*/
+
typedef struct MountPointMap {
- CONST WCHAR* volumeName; /* Native wide string volume name */
- char driveLetter; /* Drive letter corresponding to
- * the volume name. */
- struct MountPointMap* nextPtr; /* Pointer to next structure in list,
- * or NULL */
+ CONST WCHAR *volumeName; /* Native wide string volume name. */
+ char driveLetter; /* Drive letter corresponding to the volume
+ * name. */
+ struct MountPointMap *nextPtr;
+ /* Pointer to next structure in list, or
+ * NULL. */
} MountPointMap;
/*
- * This is the head of the linked list, which is protected by the
- * mutex which follows, for thread-enabled builds.
+ * This is the head of the linked list, which is protected by the mutex which
+ * follows, for thread-enabled builds.
*/
+
MountPointMap *driveLetterLookup = NULL;
TCL_DECLARE_MUTEX(mountPointMap)
-/* We will need this below */
+/*
+ * We will need this below.
+ */
+
extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
#ifdef __WIN32__
#ifndef STATIC_BUILD
-
/*
*----------------------------------------------------------------------
*
* DllEntryPoint --
*
- * This wrapper function is used by Borland to invoke the
- * initialization code for Tcl. It simply calls the DllMain
- * routine.
+ * This wrapper function is used by Borland to invoke the initialization
+ * code for Tcl. It simply calls the DllMain routine.
*
* Results:
* See DllMain.
@@ -258,21 +259,22 @@ DllEntryPoint(hInst, reason, reserved)
*
* DllMain --
*
- * This routine is called by the VC++ C run time library init
- * code, or the DllEntryPoint routine. It is responsible for
- * initializing various dynamically loaded libraries.
+ * This routine is called by the VC++ C run time library init code, or
+ * the DllEntryPoint routine. It is responsible for initializing various
+ * dynamically loaded libraries.
*
* Results:
* TRUE on sucess, FALSE on failure.
*
* Side effects:
- * Establishes 32-to-16 bit thunk and initializes sockets library.
- * This might call some sycronization functions, but MSDN
- * documentation states: "Waiting on synchronization objects in
- * DllMain can cause a deadlock."
+ * Establishes 32-to-16 bit thunk and initializes sockets library. This
+ * might call some sycronization functions, but MSDN documentation
+ * states: "Waiting on synchronization objects in DllMain can cause a
+ * deadlock."
*
*----------------------------------------------------------------------
*/
+
BOOL APIENTRY
DllMain(hInst, reason, reserved)
HINSTANCE hInst; /* Library instance handle. */
@@ -291,76 +293,79 @@ DllMain(hInst, reason, reserved)
case DLL_PROCESS_DETACH:
/*
- * Protect the call to Tcl_Finalize. The OS could be unloading
- * us from an exception handler and the state of the stack might
- * be unstable.
+ * Protect the call to Tcl_Finalize. The OS could be unloading us from
+ * an exception handler and the state of the stack might be unstable.
*/
+
#ifdef HAVE_NO_SEH
- __asm__ __volatile__ (
-
- /*
- * Construct an EXCEPTION_REGISTRATION to protect the
- * call to Tcl_Finalize
- */
- "leal %[registration], %%edx" "\n\t"
- "movl %%fs:0, %%eax" "\n\t"
- "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
- "leal 1f, %%eax" "\n\t"
- "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
- "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
- "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
- "movl %[error], 0x10(%%edx)" "\n\t" /* status */
-
- /*
- * Link the EXCEPTION_REGISTRATION on the chain
- */
- "movl %%edx, %%fs:0" "\n\t"
-
- /*
- * Call Tcl_Finalize
- */
- "call _Tcl_Finalize" "\n\t"
-
- /*
- * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION
- * and store a TCL_OK status
- */
-
- "movl %%fs:0, %%edx" "\n\t"
- "movl %[ok], %%eax" "\n\t"
- "movl %%eax, 0x10(%%edx)" "\n\t"
- "jmp 2f" "\n"
-
- /*
- * Come here on an exception. Get the EXCEPTION_REGISTRATION
- * that we previously put on the chain.
- */
-
- "1:" "\t"
- "movl %%fs:0, %%edx" "\n\t"
- "movl 0x8(%%edx), %%edx" "\n"
-
-
- /*
- * Come here however we exited. Restore context from the
- * EXCEPTION_REGISTRATION in case the stack is unbalanced.
- */
-
- "2:" "\t"
- "movl 0xc(%%edx), %%esp" "\n\t"
- "movl 0x8(%%edx), %%ebp" "\n\t"
- "movl 0x0(%%edx), %%eax" "\n\t"
- "movl %%eax, %%fs:0" "\n\t"
-
- :
- /* No outputs */
- :
- [registration] "m" (registration),
- [ok] "i" (TCL_OK),
- [error] "i" (TCL_ERROR)
- :
- "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
- );
+ __asm__ __volatile__ (
+
+ /*
+ * Construct an EXCEPTION_REGISTRATION to protect the call to
+ * Tcl_Finalize
+ */
+
+ "leal %[registration], %%edx" "\n\t"
+ "movl %%fs:0, %%eax" "\n\t"
+ "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
+ "leal 1f, %%eax" "\n\t"
+ "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
+ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
+ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
+ "movl %[error], 0x10(%%edx)" "\n\t" /* status */
+
+ /*
+ * Link the EXCEPTION_REGISTRATION on the chain
+ */
+
+ "movl %%edx, %%fs:0" "\n\t"
+
+ /*
+ * Call Tcl_Finalize
+ */
+
+ "call _Tcl_Finalize" "\n\t"
+
+ /*
+ * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION
+ * and store a TCL_OK status
+ */
+
+ "movl %%fs:0, %%edx" "\n\t"
+ "movl %[ok], %%eax" "\n\t"
+ "movl %%eax, 0x10(%%edx)" "\n\t"
+ "jmp 2f" "\n"
+
+ /*
+ * Come here on an exception. Get the EXCEPTION_REGISTRATION that
+ * we previously put on the chain.
+ */
+
+ "1:" "\t"
+ "movl %%fs:0, %%edx" "\n\t"
+ "movl 0x8(%%edx), %%edx" "\n"
+
+
+ /*
+ * Come here however we exited. Restore context from the
+ * EXCEPTION_REGISTRATION in case the stack is unbalanced.
+ */
+
+ "2:" "\t"
+ "movl 0xc(%%edx), %%esp" "\n\t"
+ "movl 0x8(%%edx), %%ebp" "\n\t"
+ "movl 0x0(%%edx), %%eax" "\n\t"
+ "movl %%eax, %%fs:0" "\n\t"
+
+ :
+ /* No outputs */
+ :
+ [registration] "m" (registration),
+ [ok] "i" (TCL_OK),
+ [error] "i" (TCL_ERROR)
+ :
+ "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
+ );
#else /* HAVE_NO_SEH */
__try {
@@ -375,7 +380,6 @@ DllMain(hInst, reason, reserved)
return TRUE;
}
-
#endif /* !STATIC_BUILD */
#endif /* __WIN32__ */
@@ -429,8 +433,8 @@ TclWinInit(hInst)
platformId = os.dwPlatformId;
/*
- * We no longer support Win32s, so just in case someone manages to
- * get a runtime there, make sure they know that.
+ * We no longer support Win32s, so just in case someone manages to get a
+ * runtime there, make sure they know that.
*/
if (platformId == VER_PLATFORM_WIN32s) {
@@ -445,8 +449,8 @@ TclWinInit(hInst)
*
* TclWinGetPlatformId --
*
- * Determines whether running under NT, 95, or Win32s, to allow
- * runtime conditional code.
+ * Determines whether running under NT, 95, or Win32s, to allow runtime
+ * conditional code.
*
* Results:
* The return value is one of:
@@ -502,8 +506,8 @@ TclWinNoBackslash(
*
* TclpCheckStackSpace --
*
- * Detect if we are about to blow the stack. Called before an
- * evaluation can happen when nesting depth is checked.
+ * Detect if we are about to blow the stack. Called before an evaluation
+ * can happen when nesting depth is checked.
*
* Results:
* 1 if there is enough stack space to continue; 0 if not.
@@ -524,95 +528,98 @@ TclpCheckStackSpace()
int retval = 0;
/*
- * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD
- * bytes of stack space left. alloca() is cheap on windows; basically
- * it just subtracts from the stack pointer causing the OS to throw an
- * exception if the stack pointer is set below the bottom of the stack.
+ * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD bytes
+ * of stack space left. alloca() is cheap on windows; basically it just
+ * subtracts from the stack pointer causing the OS to throw an exception
+ * if the stack pointer is set below the bottom of the stack.
*/
#ifdef HAVE_NO_SEH
__asm__ __volatile__ (
- /*
- * Construct an EXCEPTION_REGISTRATION to protect the
- * call to __alloca
- */
- "leal %[registration], %%edx" "\n\t"
- "movl %%fs:0, %%eax" "\n\t"
- "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
- "leal 1f, %%eax" "\n\t"
- "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
- "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
- "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
- "movl %[error], 0x10(%%edx)" "\n\t" /* status */
-
- /*
- * Link the EXCEPTION_REGISTRATION on the chain
- */
- "movl %%edx, %%fs:0" "\n\t"
-
- /*
- * Attempt a call to __alloca, to determine whether there's
- * sufficient memory to be had.
- */
-
- "movl %[size], %%eax" "\n\t"
- "pushl %%eax" "\n\t"
- "call __alloca" "\n\t"
-
- /*
- * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION
- * and store a TCL_OK status
- */
- "movl %%fs:0, %%edx" "\n\t"
- "movl %[ok], %%eax" "\n\t"
- "movl %%eax, 0x10(%%edx)" "\n\t"
- "jmp 2f" "\n"
-
- /*
- * Come here on an exception. Get the EXCEPTION_REGISTRATION
- * that we previously put on the chain.
- */
- "1:" "\t"
- "movl %%fs:0, %%edx" "\n\t"
- "movl 0x8(%%edx), %%edx" "\n\t"
-
- /*
- * Come here however we exited. Restore context from the
- * EXCEPTION_REGISTRATION in case the stack is unbalanced.
- */
-
- "2:" "\t"
- "movl 0xc(%%edx), %%esp" "\n\t"
- "movl 0x8(%%edx), %%ebp" "\n\t"
- "movl 0x0(%%edx), %%eax" "\n\t"
- "movl %%eax, %%fs:0" "\n\t"
-
- :
- /* No outputs */
- :
- [registration] "m" (registration),
- [ok] "i" (TCL_OK),
- [error] "i" (TCL_ERROR),
- [size] "i" (TCL_WIN_STACK_THRESHOLD)
- :
- "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
- );
+ /*
+ * Construct an EXCEPTION_REGISTRATION to protect the call to __alloca
+ */
+
+ "leal %[registration], %%edx" "\n\t"
+ "movl %%fs:0, %%eax" "\n\t"
+ "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
+ "leal 1f, %%eax" "\n\t"
+ "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
+ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
+ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
+ "movl %[error], 0x10(%%edx)" "\n\t" /* status */
+
+ /*
+ * Link the EXCEPTION_REGISTRATION on the chain
+ */
+
+ "movl %%edx, %%fs:0" "\n\t"
+
+ /*
+ * Attempt a call to __alloca, to determine whether there's sufficient
+ * memory to be had.
+ */
+
+ "movl %[size], %%eax" "\n\t"
+ "pushl %%eax" "\n\t"
+ "call __alloca" "\n\t"
+
+ /*
+ * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and
+ * store a TCL_OK status
+ */
+
+ "movl %%fs:0, %%edx" "\n\t"
+ "movl %[ok], %%eax" "\n\t"
+ "movl %%eax, 0x10(%%edx)" "\n\t"
+ "jmp 2f" "\n"
+
+ /*
+ * Come here on an exception. Get the EXCEPTION_REGISTRATION that we
+ * previously put on the chain.
+ */
+
+ "1:" "\t"
+ "movl %%fs:0, %%edx" "\n\t"
+ "movl 0x8(%%edx), %%edx" "\n\t"
+
+ /*
+ * Come here however we exited. Restore context from the
+ * EXCEPTION_REGISTRATION in case the stack is unbalanced.
+ */
+
+ "2:" "\t"
+ "movl 0xc(%%edx), %%esp" "\n\t"
+ "movl 0x8(%%edx), %%ebp" "\n\t"
+ "movl 0x0(%%edx), %%eax" "\n\t"
+ "movl %%eax, %%fs:0" "\n\t"
+
+ :
+ /* No outputs */
+ :
+ [registration] "m" (registration),
+ [ok] "i" (TCL_OK),
+ [error] "i" (TCL_ERROR),
+ [size] "i" (TCL_WIN_STACK_THRESHOLD)
+ :
+ "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
+ );
retval = (registration.status == TCL_OK);
#else /* !HAVE_NO_SEH */
__try {
#ifdef HAVE_ALLOCA_GCC_INLINE
- __asm__ __volatile__ (
- "movl %0, %%eax" "\n\t"
- "call __alloca" "\n\t"
- :
- : "i"(TCL_WIN_STACK_THRESHOLD)
- : "%eax");
+ __asm__ __volatile__ (
+ "movl %0, %%eax" "\n\t"
+ "call __alloca" "\n\t"
+ :
+ : "i"(TCL_WIN_STACK_THRESHOLD)
+ : "%eax");
#else
- alloca(TCL_WIN_STACK_THRESHOLD);
+ alloca(TCL_WIN_STACK_THRESHOLD);
#endif /* HAVE_ALLOCA_GCC_INLINE */
- retval = 1;
+ retval = 1;
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif /* HAVE_NO_SEH */
@@ -624,123 +631,123 @@ TclpCheckStackSpace()
*
* TclWinSetInterfaces --
*
- * A helper proc that allows the test library to change the
- * tclWinProcs structure to dispatch to either the wide-character
- * or multi-byte versions of the operating system calls, depending
- * on whether Unicode is the system encoding.
- *
- * As well as this, we can also try to load in some additional
- * procs which may/may not be present depending on the current
- * Windows version (e.g. Win95 will not have the procs below).
+ * A helper proc that allows the test library to change the tclWinProcs
+ * structure to dispatch to either the wide-character or multi-byte
+ * versions of the operating system calls, depending on whether Unicode
+ * is the system encoding.
+ *
+ * As well as this, we can also try to load in some additional procs
+ * which may/may not be present depending on the current Windows version
+ * (e.g. Win95 will not have the procs below).
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * None.
+ * None.
*
*---------------------------------------------------------------------------
*/
void
TclWinSetInterfaces(
- int wide) /* Non-zero to use wide interfaces, 0
- * otherwise. */
+ int wide) /* Non-zero to use wide interfaces, 0
+ * otherwise. */
{
Tcl_FreeEncoding(tclWinTCharEncoding);
if (wide) {
- tclWinProcs = &unicodeProcs;
- tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
- if (tclWinProcs->getFileAttributesExProc == NULL) {
- HINSTANCE hInstance = LoadLibraryA("kernel32");
- if (hInstance != NULL) {
- tclWinProcs->getFileAttributesExProc =
- (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
- LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW");
- tclWinProcs->createHardLinkProc =
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
- LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
- "CreateHardLinkW");
- tclWinProcs->findFirstFileExProc =
- (HANDLE (WINAPI *)(CONST TCHAR*, UINT,
- LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance,
- "FindFirstFileExW");
- tclWinProcs->getVolumeNameForVMPProc =
- (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*,
- DWORD)) GetProcAddress(hInstance,
- "GetVolumeNameForVolumeMountPointW");
- tclWinProcs->getLongPathNameProc =
- (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*,
- DWORD)) GetProcAddress(hInstance,
- "GetLongPathNameW");
- FreeLibrary(hInstance);
- }
- hInstance = LoadLibraryA("advapi32");
- if (hInstance != NULL) {
- tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)(
- LPCTSTR lpFileName,
- SECURITY_INFORMATION RequestedInformation,
- PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength,
- LPDWORD lpnLengthNeeded)) GetProcAddress(hInstance,
- "GetFileSecurityW");
- tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) (
- SECURITY_IMPERSONATION_LEVEL ImpersonationLevel))
- GetProcAddress(hInstance, "ImpersonateSelf");
- tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) (
- HANDLE ThreadHandle, DWORD DesiredAccess, BOOL OpenAsSelf,
- PHANDLE TokenHandle)) GetProcAddress(hInstance,
- "OpenThreadToken");
- tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void))
- GetProcAddress(hInstance, "RevertToSelf");
- tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) (
- PDWORD AccessMask, PGENERIC_MAPPING GenericMapping))
- GetProcAddress(hInstance, "MapGenericMask");
- tclWinProcs->accessCheckProc = (BOOL (WINAPI *)(
- PSECURITY_DESCRIPTOR pSecurityDescriptor,
- HANDLE ClientToken, DWORD DesiredAccess,
- PGENERIC_MAPPING GenericMapping,
- PPRIVILEGE_SET PrivilegeSet,
- LPDWORD PrivilegeSetLength,
- LPDWORD GrantedAccess,
- LPBOOL AccessStatus)) GetProcAddress(hInstance,
- "AccessCheck");
- FreeLibrary(hInstance);
- }
- }
+ tclWinProcs = &unicodeProcs;
+ tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
+ if (tclWinProcs->getFileAttributesExProc == NULL) {
+ HINSTANCE hInstance = LoadLibraryA("kernel32");
+ if (hInstance != NULL) {
+ tclWinProcs->getFileAttributesExProc =
+ (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
+ LPVOID)) GetProcAddress(hInstance,
+ "GetFileAttributesExW");
+ tclWinProcs->createHardLinkProc =
+ (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
+ LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
+ "CreateHardLinkW");
+ tclWinProcs->findFirstFileExProc =
+ (HANDLE (WINAPI *)(CONST TCHAR*, UINT, LPVOID, UINT,
+ LPVOID, DWORD)) GetProcAddress(hInstance,
+ "FindFirstFileExW");
+ tclWinProcs->getVolumeNameForVMPProc =
+ (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*,
+ DWORD)) GetProcAddress(hInstance,
+ "GetVolumeNameForVolumeMountPointW");
+ tclWinProcs->getLongPathNameProc =
+ (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*,
+ DWORD)) GetProcAddress(hInstance, "GetLongPathNameW");
+ FreeLibrary(hInstance);
+ }
+ hInstance = LoadLibraryA("advapi32");
+ if (hInstance != NULL) {
+ tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)(
+ LPCTSTR lpFileName,
+ SECURITY_INFORMATION RequestedInformation,
+ PSECURITY_DESCRIPTOR pSecurityDescriptor,
+ DWORD nLength, LPDWORD lpnLengthNeeded))
+ GetProcAddress(hInstance, "GetFileSecurityW");
+ tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) (
+ SECURITY_IMPERSONATION_LEVEL ImpersonationLevel))
+ GetProcAddress(hInstance, "ImpersonateSelf");
+ tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) (
+ HANDLE ThreadHandle, DWORD DesiredAccess,
+ BOOL OpenAsSelf, PHANDLE TokenHandle))
+ GetProcAddress(hInstance, "OpenThreadToken");
+ tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void))
+ GetProcAddress(hInstance, "RevertToSelf");
+ tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) (
+ PDWORD AccessMask, PGENERIC_MAPPING GenericMapping))
+ GetProcAddress(hInstance, "MapGenericMask");
+ tclWinProcs->accessCheckProc = (BOOL (WINAPI *)(
+ PSECURITY_DESCRIPTOR pSecurityDescriptor,
+ HANDLE ClientToken, DWORD DesiredAccess,
+ PGENERIC_MAPPING GenericMapping,
+ PPRIVILEGE_SET PrivilegeSet,
+ LPDWORD PrivilegeSetLength, LPDWORD GrantedAccess,
+ LPBOOL AccessStatus)) GetProcAddress(hInstance,
+ "AccessCheck");
+ FreeLibrary(hInstance);
+ }
+ }
} else {
- tclWinProcs = &asciiProcs;
- tclWinTCharEncoding = NULL;
- if (tclWinProcs->getFileAttributesExProc == NULL) {
- HINSTANCE hInstance = LoadLibraryA("kernel32");
- if (hInstance != NULL) {
- tclWinProcs->getFileAttributesExProc =
- (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
- LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA");
- tclWinProcs->createHardLinkProc =
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
- LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
- "CreateHardLinkA");
- tclWinProcs->findFirstFileExProc = NULL;
- tclWinProcs->getLongPathNameProc = NULL;
- /*
- * The 'findFirstFileExProc' function exists on some
- * of 95/98/ME, but it seems not to work as anticipated.
- * Therefore we don't set this function pointer. The
- * relevant code will fall back on a slower approach
- * using the normal findFirstFileProc.
- *
- * (HANDLE (WINAPI *)(CONST TCHAR*, UINT,
- * LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance,
- * "FindFirstFileExA");
- */
- tclWinProcs->getVolumeNameForVMPProc =
- (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*,
- DWORD)) GetProcAddress(hInstance,
- "GetVolumeNameForVolumeMountPointA");
- FreeLibrary(hInstance);
- }
- }
+ tclWinProcs = &asciiProcs;
+ tclWinTCharEncoding = NULL;
+ if (tclWinProcs->getFileAttributesExProc == NULL) {
+ HINSTANCE hInstance = LoadLibraryA("kernel32");
+ if (hInstance != NULL) {
+ tclWinProcs->getFileAttributesExProc =
+ (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
+ LPVOID)) GetProcAddress(hInstance,
+ "GetFileAttributesExA");
+ tclWinProcs->createHardLinkProc =
+ (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
+ LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
+ "CreateHardLinkA");
+ tclWinProcs->findFirstFileExProc = NULL;
+ tclWinProcs->getLongPathNameProc = NULL;
+ /*
+ * The 'findFirstFileExProc' function exists on some of
+ * 95/98/ME, but it seems not to work as anticipated.
+ * Therefore we don't set this function pointer. The relevant
+ * code will fall back on a slower approach using the normal
+ * findFirstFileProc.
+ *
+ * (HANDLE (WINAPI *)(CONST TCHAR*, UINT,
+ * LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance,
+ * "FindFirstFileExA");
+ */
+ tclWinProcs->getVolumeNameForVMPProc =
+ (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*,
+ DWORD)) GetProcAddress(hInstance,
+ "GetVolumeNameForVolumeMountPointA");
+ FreeLibrary(hInstance);
+ }
+ }
}
}
@@ -749,39 +756,43 @@ TclWinSetInterfaces(
*
* TclWinResetInterfaceEncodings --
*
- * Called during finalization to free up any encodings we use.
- * The tclWinProcs-> look up table is still ok to use after
- * this call, provided no encoding conversion is required.
+ * Called during finalization to free up any encodings we use. The
+ * tclWinProcs-> look up table is still ok to use after this call,
+ * provided no encoding conversion is required.
*
- * We also clean up any memory allocated in our mount point
- * map which is used to follow certain kinds of symlinks.
- * That code should never be used once encodings are taken
- * down.
- *
+ * We also clean up any memory allocated in our mount point map which is
+ * used to follow certain kinds of symlinks. That code should never be
+ * used once encodings are taken down.
+ *
* Results:
- * None.
+ * None.
*
* Side effects:
- * None.
+ * None.
*
*---------------------------------------------------------------------------
*/
+
void
TclWinResetInterfaceEncodings()
{
MountPointMap *dlIter, *dlIter2;
if (tclWinTCharEncoding != NULL) {
- Tcl_FreeEncoding(tclWinTCharEncoding);
- tclWinTCharEncoding = NULL;
+ Tcl_FreeEncoding(tclWinTCharEncoding);
+ tclWinTCharEncoding = NULL;
}
- /* Clean up the mount point map */
+
+ /*
+ * Clean up the mount point map.
+ */
+
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
- dlIter2 = dlIter->nextPtr;
- ckfree((char*)dlIter->volumeName);
- ckfree((char*)dlIter);
- dlIter = dlIter2;
+ dlIter2 = dlIter->nextPtr;
+ ckfree((char*)dlIter->volumeName);
+ ckfree((char*)dlIter);
+ dlIter = dlIter2;
}
Tcl_MutexUnlock(&mountPointMap);
}
@@ -791,15 +802,15 @@ TclWinResetInterfaceEncodings()
*
* TclWinResetInterfaces --
*
- * Called during finalization to reset us to a safe state for reuse.
- * After this call, it is best not to use the tclWinProcs-> look
- * up table since it is likely to be different to what is expected.
+ * Called during finalization to reset us to a safe state for reuse.
+ * After this call, it is best not to use the tclWinProcs-> look up table
+ * since it is likely to be different to what is expected.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * None.
+ * None.
*
*---------------------------------------------------------------------------
*/
@@ -814,121 +825,149 @@ TclWinResetInterfaces()
*
* TclWinDriveLetterForVolMountPoint
*
- * Unfortunately, Windows provides no easy way at all to get hold
- * of the drive letter for a volume mount point, but we need that
- * information to understand paths correctly. So, we have to
- * build an associated array to find these correctly, and allow
- * quick and easy lookup from volume mount points to drive letters.
+ * Unfortunately, Windows provides no easy way at all to get hold of the
+ * drive letter for a volume mount point, but we need that information to
+ * understand paths correctly. So, we have to build an associated array
+ * to find these correctly, and allow quick and easy lookup from volume
+ * mount points to drive letters.
*
- * We assume here that we are running on a system for which the wide
- * character interfaces are used, which is valid for Win 2000 and WinXP
- * which are the only systems on which this function will ever be called.
+ * We assume here that we are running on a system for which the wide
+ * character interfaces are used, which is valid for Win 2000 and WinXP
+ * which are the only systems on which this function will ever be called.
*
- * Result: the drive letter, or -1 if no drive letter corresponds to
- * the given mount point.
+ * Result:
+ * The drive letter, or -1 if no drive letter corresponds to the given
+ * mount point.
*
*--------------------------------------------------------------------
*/
+
char
TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint)
{
MountPointMap *dlIter, *dlPtr2;
- WCHAR Target[55]; /* Target of mount at mount point */
+ WCHAR Target[55]; /* Target of mount at mount point */
WCHAR drive[4] = { L'A', L':', L'\\', L'\0' };
/*
- * Detect the volume mounted there. Unfortunately, there is no
- * simple way to map a unique volume name to a DOS drive letter.
- * So, we have to build an associative array.
+ * Detect the volume mounted there. Unfortunately, there is no simple way
+ * to map a unique volume name to a DOS drive letter. So, we have to build
+ * an associative array.
*/
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
- if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
- /*
- * We need to check whether this information is
- * still valid, since either the user or various
- * programs could have adjusted the mount points on
- * the fly.
- */
- drive[0] = L'A' + (dlIter->driveLetter - 'A');
- /* Try to read the volume mount point and see where it points */
- if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive,
- (TCHAR*)Target, 55) != 0) {
- if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
- /* Nothing has changed */
- Tcl_MutexUnlock(&mountPointMap);
- return dlIter->driveLetter;
- }
- }
- /*
- * If we reach here, unfortunately, this mount point is
- * no longer valid at all
- */
- if (driveLetterLookup == dlIter) {
- dlPtr2 = dlIter;
- driveLetterLookup = dlIter->nextPtr;
- } else {
- for (dlPtr2 = driveLetterLookup;
- dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) {
- if (dlPtr2->nextPtr == dlIter) {
- dlPtr2->nextPtr = dlIter->nextPtr;
- dlPtr2 = dlIter;
- break;
- }
- }
- }
- /* Now dlPtr2 points to the structure to free */
- ckfree((char*)dlPtr2->volumeName);
- ckfree((char*)dlPtr2);
- /*
- * Restart the loop --- we could try to be clever
- * and continue half way through, but the logic is a
- * bit messy, so it's cleanest just to restart
- */
- dlIter = driveLetterLookup;
- continue;
- }
- dlIter = dlIter->nextPtr;
+ if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
+ /*
+ * We need to check whether this information is still valid, since
+ * either the user or various programs could have adjusted the
+ * mount points on the fly.
+ */
+
+ drive[0] = L'A' + (dlIter->driveLetter - 'A');
+
+ /*
+ * Try to read the volume mount point and see where it points.
+ */
+
+ if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive,
+ (TCHAR*)Target, 55) != 0) {
+ if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
+ /*
+ * Nothing has changed.
+ */
+
+ Tcl_MutexUnlock(&mountPointMap);
+ return dlIter->driveLetter;
+ }
+ }
+
+ /*
+ * If we reach here, unfortunately, this mount point is no longer
+ * valid at all.
+ */
+
+ if (driveLetterLookup == dlIter) {
+ dlPtr2 = dlIter;
+ driveLetterLookup = dlIter->nextPtr;
+ } else {
+ for (dlPtr2 = driveLetterLookup;
+ dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) {
+ if (dlPtr2->nextPtr == dlIter) {
+ dlPtr2->nextPtr = dlIter->nextPtr;
+ dlPtr2 = dlIter;
+ break;
+ }
+ }
+ }
+
+ /*
+ * Now dlPtr2 points to the structure to free.
+ */
+
+ ckfree((char*)dlPtr2->volumeName);
+ ckfree((char*)dlPtr2);
+
+ /*
+ * Restart the loop - we could try to be clever and continue half
+ * way through, but the logic is a bit messy, so it's cleanest
+ * just to restart.
+ */
+
+ dlIter = driveLetterLookup;
+ continue;
+ }
+ dlIter = dlIter->nextPtr;
}
- /* We couldn't find it, so we must iterate over the letters */
+ /*
+ * We couldn't find it, so we must iterate over the letters.
+ */
for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) {
- /* Try to read the volume mount point and see where it points */
- if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive,
- (TCHAR*)Target, 55) != 0) {
- int alreadyStored = 0;
- for (dlIter = driveLetterLookup; dlIter != NULL;
- dlIter = dlIter->nextPtr) {
- if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
- alreadyStored = 1;
- break;
- }
- }
- if (!alreadyStored) {
- dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap));
- dlPtr2->volumeName = TclNativeDupInternalRep(Target);
- dlPtr2->driveLetter = 'A' + (drive[0] - L'A');
- dlPtr2->nextPtr = driveLetterLookup;
- driveLetterLookup = dlPtr2;
- }
- }
+ /*
+ * Try to read the volume mount point and see where it points.
+ */
+
+ if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive,
+ (TCHAR*)Target, 55) != 0) {
+ int alreadyStored = 0;
+
+ for (dlIter = driveLetterLookup; dlIter != NULL;
+ dlIter = dlIter->nextPtr) {
+ if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
+ alreadyStored = 1;
+ break;
+ }
+ }
+ if (!alreadyStored) {
+ dlPtr2 = (MountPointMap *) ckalloc(sizeof(MountPointMap));
+ dlPtr2->volumeName = TclNativeDupInternalRep(Target);
+ dlPtr2->driveLetter = 'A' + (drive[0] - L'A');
+ dlPtr2->nextPtr = driveLetterLookup;
+ driveLetterLookup = dlPtr2;
+ }
+ }
}
- /* Try again */
+
+ /*
+ * Try again.
+ */
+
for (dlIter = driveLetterLookup; dlIter != NULL;
- dlIter = dlIter->nextPtr) {
- if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
- Tcl_MutexUnlock(&mountPointMap);
- return dlIter->driveLetter;
- }
+ dlIter = dlIter->nextPtr) {
+ if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
+ Tcl_MutexUnlock(&mountPointMap);
+ return dlIter->driveLetter;
+ }
}
+
/*
- * The volume doesn't appear to correspond to a drive letter -- we
- * remember that fact and store '-1' so we don't have to look it
- * up each time.
+ * The volume doesn't appear to correspond to a drive letter - we remember
+ * that fact and store '-1' so we don't have to look it up each time.
*/
+
dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap));
dlPtr2->volumeName = TclNativeDupInternalRep((ClientData)mountPoint);
dlPtr2->driveLetter = -1;
@@ -943,78 +982,74 @@ TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint)
*
* Tcl_WinUtfToTChar, Tcl_WinTCharToUtf --
*
- * Convert between UTF-8 and Unicode when running Windows NT or
- * the current ANSI code page when running Windows 95.
- *
- * On Mac, Unix, and Windows 95, all strings exchanged between Tcl
- * and the OS are "char" oriented. We need only one Tcl_Encoding to
- * convert between UTF-8 and the system's native encoding. We use
- * NULL to represent that encoding.
- *
- * On NT, some strings exchanged between Tcl and the OS are "char"
- * oriented, while others are in Unicode. We need two Tcl_Encoding
- * APIs depending on whether we are targeting a "char" or Unicode
- * interface.
- *
- * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an
- * encoding of NULL should always used to convert between UTF-8
- * and the system's "char" oriented encoding. The following two
- * functions are used in Windows-specific code to convert between
- * UTF-8 and Unicode strings (NT) or "char" strings(95). This saves
- * you the trouble of writing the following type of fragment over and
- * over:
- *
- * if (running NT) {
- * encoding <- Tcl_GetEncoding("unicode");
- * nativeBuffer <- UtfToExternal(encoding, utfBuffer);
- * Tcl_FreeEncoding(encoding);
- * } else {
- * nativeBuffer <- UtfToExternal(NULL, utfBuffer);
- * }
- *
- * By convention, in Windows a TCHAR is a character in the ANSI code
- * page on Windows 95, a Unicode character on Windows NT. If you
- * plan on targeting a Unicode interfaces when running on NT and a
- * "char" oriented interface while running on 95, these functions
- * should be used. If you plan on targetting the same "char"
- * oriented function on both 95 and NT, use Tcl_UtfToExternal()
- * with an encoding of NULL.
+ * Convert between UTF-8 and Unicode when running Windows NT or the
+ * current ANSI code page when running Windows 95.
+ *
+ * On Mac, Unix, and Windows 95, all strings exchanged between Tcl and
+ * the OS are "char" oriented. We need only one Tcl_Encoding to convert
+ * between UTF-8 and the system's native encoding. We use NULL to
+ * represent that encoding.
+ *
+ * On NT, some strings exchanged between Tcl and the OS are "char"
+ * oriented, while others are in Unicode. We need two Tcl_Encoding APIs
+ * depending on whether we are targeting a "char" or Unicode interface.
+ *
+ * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding of
+ * NULL should always used to convert between UTF-8 and the system's
+ * "char" oriented encoding. The following two functions are used in
+ * Windows-specific code to convert between UTF-8 and Unicode strings
+ * (NT) or "char" strings(95). This saves you the trouble of writing the
+ * following type of fragment over and over:
+ *
+ * if (running NT) {
+ * encoding <- Tcl_GetEncoding("unicode");
+ * nativeBuffer <- UtfToExternal(encoding, utfBuffer);
+ * Tcl_FreeEncoding(encoding);
+ * } else {
+ * nativeBuffer <- UtfToExternal(NULL, utfBuffer);
+ * }
+ *
+ * By convention, in Windows a TCHAR is a character in the ANSI code page
+ * on Windows 95, a Unicode character on Windows NT. If you plan on
+ * targeting a Unicode interfaces when running on NT and a "char"
+ * oriented interface while running on 95, these functions should be
+ * used. If you plan on targetting the same "char" oriented function on
+ * both 95 and NT, use Tcl_UtfToExternal() with an encoding of NULL.
*
* Results:
- * The result is a pointer to the string in the desired target
- * encoding. Storage for the result string is allocated in
- * dsPtr; the caller must call Tcl_DStringFree() when the result
- * is no longer needed.
+ * The result is a pointer to the string in the desired target encoding.
+ * Storage for the result string is allocated in dsPtr; the caller must
+ * call Tcl_DStringFree() when the result is no longer needed.
*
* Side effects:
- * None.
+ * None.
*
*---------------------------------------------------------------------------
*/
TCHAR *
Tcl_WinUtfToTChar(string, len, dsPtr)
- CONST char *string; /* Source string in UTF-8. */
- int len; /* Source string length in bytes, or < 0 for
- * strlen(). */
- Tcl_DString *dsPtr; /* Uninitialized or free DString in which
- * the converted string is stored. */
+ CONST char *string; /* Source string in UTF-8. */
+ int len; /* Source string length in bytes, or < 0 for
+ * strlen(). */
+ Tcl_DString *dsPtr; /* Uninitialized or free DString in which the
+ * converted string is stored. */
{
return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding,
- string, len, dsPtr);
+ string, len, dsPtr);
}
char *
Tcl_WinTCharToUtf(string, len, dsPtr)
- CONST TCHAR *string; /* Source string in Unicode when running
- * NT, ANSI when running 95. */
- int len; /* Source string length in bytes, or < 0 for
- * platform-specific string length. */
- Tcl_DString *dsPtr; /* Uninitialized or free DString in which
- * the converted string is stored. */
+ CONST TCHAR *string; /* Source string in Unicode when running NT,
+ * ANSI when running 95. */
+ int len; /* Source string length in bytes, or < 0 for
+ * platform-specific string length. */
+ Tcl_DString *dsPtr; /* Uninitialized or free DString in which the
+ * converted string is stored. */
{
return Tcl_ExternalToUtfDString(tclWinTCharEncoding,
- (CONST char *) string, len, dsPtr);
+ (CONST char *) string, len, dsPtr);
}
/*
@@ -1022,112 +1057,115 @@ Tcl_WinTCharToUtf(string, len, dsPtr)
*
* TclWinCPUID --
*
- * Get CPU ID information on an Intel box under Windows
+ * Get CPU ID information on an Intel box under Windows
*
* Results:
- * Returns TCL_OK if successful, TCL_ERROR if CPUID is not
- * supported or fails.
+ * Returns TCL_OK if successful, TCL_ERROR if CPUID is not supported or
+ * fails.
*
* Side effects:
- * If successful, stores EAX, EBX, ECX and EDX registers after
- * the CPUID instruction in the four integers designated by 'regsPtr'
+ * If successful, stores EAX, EBX, ECX and EDX registers after the CPUID
+ * instruction in the four integers designated by 'regsPtr'
*
*----------------------------------------------------------------------
*/
int
-TclWinCPUID( unsigned int index, /* Which CPUID value to retrieve */
- unsigned int * regsPtr ) /* Registers after the CPUID */
+TclWinCPUID(
+ unsigned int index, /* Which CPUID value to retrieve. */
+ unsigned int *regsPtr) /* Registers after the CPUID. */
{
-
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
#endif
int status = TCL_ERROR;
#if defined(__GNUC__) && !defined(_WIN64)
-
/*
- * Execute the CPUID instruction with the given index, and
- * store results off 'regPtr'.
+ * Execute the CPUID instruction with the given index, and store results
+ * off 'regPtr'.
*/
- __asm__ __volatile__ (
+ __asm__ __volatile__(
+ /*
+ * Construct an EXCEPTION_REGISTRATION to protect the CPUID
+ * instruction (early 486's don't have CPUID)
+ */
+
+ "leal %[registration], %%edx" "\n\t"
+ "movl %%fs:0, %%eax" "\n\t"
+ "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
+ "leal 1f, %%eax" "\n\t"
+ "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
+ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
+ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
+ "movl %[error], 0x10(%%edx)" "\n\t" /* status */
+
+ /*
+ * Link the EXCEPTION_REGISTRATION on the chain
+ */
+
+ "movl %%edx, %%fs:0" "\n\t"
- /*
- * Construct an EXCEPTION_REGISTRATION to protect the
- * CPUID instruction (early 486's don't have CPUID)
- */
- "leal %[registration], %%edx" "\n\t"
- "movl %%fs:0, %%eax" "\n\t"
- "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
- "leal 1f, %%eax" "\n\t"
- "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
- "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
- "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
- "movl %[error], 0x10(%%edx)" "\n\t" /* status */
-
- /*
- * Link the EXCEPTION_REGISTRATION on the chain
- */
- "movl %%edx, %%fs:0" "\n\t"
-
- /*
- * Do the CPUID instruction, and save the results in
- * the 'regsPtr' area
- */
-
- "movl %[rptr], %%edi" "\n\t"
- "movl %[index], %%eax" "\n\t"
- "cpuid" "\n\t"
- "movl %%eax, 0x0(%%edi)" "\n\t"
- "movl %%ebx, 0x4(%%edi)" "\n\t"
- "movl %%ecx, 0x8(%%edi)" "\n\t"
- "movl %%edx, 0xc(%%edi)" "\n\t"
-
- /*
- * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION
- * and store a TCL_OK status
- */
- "movl %%fs:0, %%edx" "\n\t"
- "movl %[ok], %%eax" "\n\t"
- "movl %%eax, 0x10(%%edx)" "\n\t"
- "jmp 2f" "\n"
-
- /*
- * Come here on an exception. Get the EXCEPTION_REGISTRATION
- * that we previously put on the chain.
- */
- "1:" "\t"
- "movl %%fs:0, %%edx" "\n\t"
- "movl 0x8(%%edx), %%edx" "\n\t"
-
- /*
- * Come here however we exited. Restore context from the
- * EXCEPTION_REGISTRATION in case the stack is unbalanced.
- */
-
- "2:" "\t"
- "movl 0xc(%%edx), %%esp" "\n\t"
- "movl 0x8(%%edx), %%ebp" "\n\t"
- "movl 0x0(%%edx), %%eax" "\n\t"
- "movl %%eax, %%fs:0" "\n\t"
-
- :
- /* No outputs */
- :
- [index] "m" (index),
- [rptr] "m" (regsPtr),
- [registration] "m" (registration),
- [ok] "i" (TCL_OK),
- [error] "i" (TCL_ERROR)
- :
- "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" );
+ /*
+ * Do the CPUID instruction, and save the results in the 'regsPtr'
+ * area.
+ */
+
+ "movl %[rptr], %%edi" "\n\t"
+ "movl %[index], %%eax" "\n\t"
+ "cpuid" "\n\t"
+ "movl %%eax, 0x0(%%edi)" "\n\t"
+ "movl %%ebx, 0x4(%%edi)" "\n\t"
+ "movl %%ecx, 0x8(%%edi)" "\n\t"
+ "movl %%edx, 0xc(%%edi)" "\n\t"
+
+ /*
+ * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and
+ * store a TCL_OK status.
+ */
+
+ "movl %%fs:0, %%edx" "\n\t"
+ "movl %[ok], %%eax" "\n\t"
+ "movl %%eax, 0x10(%%edx)" "\n\t"
+ "jmp 2f" "\n"
+
+ /*
+ * Come here on an exception. Get the EXCEPTION_REGISTRATION that we
+ * previously put on the chain.
+ */
+
+ "1:" "\t"
+ "movl %%fs:0, %%edx" "\n\t"
+ "movl 0x8(%%edx), %%edx" "\n\t"
+
+ /*
+ * Come here however we exited. Restore context from the
+ * EXCEPTION_REGISTRATION in case the stack is unbalanced.
+ */
+
+ "2:" "\t"
+ "movl 0xc(%%edx), %%esp" "\n\t"
+ "movl 0x8(%%edx), %%ebp" "\n\t"
+ "movl 0x0(%%edx), %%eax" "\n\t"
+ "movl %%eax, %%fs:0" "\n\t"
+
+ :
+ /* No outputs */
+ :
+ [index] "m" (index),
+ [rptr] "m" (regsPtr),
+ [registration] "m" (registration),
+ [ok] "i" (TCL_OK),
+ [error] "i" (TCL_ERROR)
+ :
+ "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory");
status = registration.status;
#elif defined(_MSC_VER) && !defined(_WIN64)
-
- /* Define a structure in the stack frame to hold the registers */
+ /*
+ * Define a structure in the stack frame to hold the registers.
+ */
struct {
DWORD dw0;
@@ -1137,39 +1175,53 @@ TclWinCPUID( unsigned int index, /* Which CPUID value to retrieve */
} regs;
regs.dw0 = index;
- /* Execute the CPUID instruction and save regs in the stack frame */
+ /*
+ * Execute the CPUID instruction and save regs in the stack frame.
+ */
_try {
_asm {
push ebx
push ecx
push edx
- mov eax, regs.dw0
+ mov eax, regs.dw0
cpuid
- mov regs.dw0, eax
- mov regs.dw1, ebx
- mov regs.dw2, ecx
- mov regs.dw3, edx
- pop edx
- pop ecx
- pop ebx
+ mov regs.dw0, eax
+ mov regs.dw1, ebx
+ mov regs.dw2, ecx
+ mov regs.dw3, edx
+ pop edx
+ pop ecx
+ pop ebx
}
- /* Copy regs back out to the caller */
+ /*
+ * Copy regs back out to the caller.
+ */
- regsPtr[0]=regs.dw0;
- regsPtr[1]=regs.dw1;
- regsPtr[2]=regs.dw2;
- regsPtr[3]=regs.dw3;
+ regsPtr[0] = regs.dw0;
+ regsPtr[1] = regs.dw1;
+ regsPtr[2] = regs.dw2;
+ regsPtr[3] = regs.dw3;
status = TCL_OK;
- } __except( EXCEPTION_EXECUTE_HANDLER ) {
+ } __except(EXCEPTION_EXECUTE_HANDLER) {
+ /* do nothing */
}
#else
- /* Don't know how to do assembly code for
- * this compiler and/or architecture */
+ /*
+ * Don't know how to do assembly code for this compiler and/or
+ * architecture.
+ */
#endif
return status;
}
-
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index db8b75b..66b332d 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -1,15 +1,15 @@
/*
* tclWinChan.c
*
- * Channel drivers for Windows channels based on files, command
- * pipes and TCP sockets.
+ * Channel drivers for Windows channels based on files, command pipes and
+ * TCP sockets.
*
* Copyright (c) 1995-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: tclWinChan.c,v 1.43 2005/06/23 19:48:50 kennykb Exp $
+ * RCS: @(#) $Id: tclWinChan.c,v 1.44 2005/07/24 22:56:46 dkf Exp $
*/
#include "tclWinInt.h"
@@ -42,7 +42,7 @@ typedef struct FileInfo {
HANDLE handle; /* Input/output file. */
struct FileInfo *nextPtr; /* Pointer to next registered file. */
int dirty; /* Boolean flag. Set if the OS may have data
- * pending on the channel */
+ * pending on the channel. */
} FileInfo;
typedef struct ThreadSpecificData {
@@ -56,16 +56,16 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
/*
- * The following structure is what is added to the Tcl event queue when
- * file events are generated.
+ * The following structure is what is added to the Tcl event queue when file
+ * events are generated.
*/
typedef struct FileEvent {
- Tcl_Event header; /* Information that is standard for
- * all events. */
- FileInfo *infoPtr; /* Pointer to file info structure. Note
- * that we still have to verify that the
- * file exists before dereferencing this
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ FileInfo *infoPtr; /* Pointer to file info structure. Note that
+ * we still have to verify that the file
+ * exists before dereferencing this
* pointer. */
} FileEvent;
@@ -73,35 +73,29 @@ typedef struct FileEvent {
* Static routines for this file:
*/
-static int FileBlockProc _ANSI_ARGS_((ClientData instanceData,
- int mode));
-static void FileChannelExitHandler _ANSI_ARGS_((
- ClientData clientData));
-static void FileCheckProc _ANSI_ARGS_((ClientData clientData,
- int flags));
-static int FileCloseProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp));
-static int FileEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
- int flags));
-static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData,
- int direction, ClientData *handlePtr));
-static ThreadSpecificData *FileInit _ANSI_ARGS_((void));
-static int FileInputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toRead, int *errorCode));
-static int FileOutputProc _ANSI_ARGS_((ClientData instanceData,
- CONST char *buf, int toWrite, int *errorCode));
-static int FileSeekProc _ANSI_ARGS_((ClientData instanceData,
- long offset, int mode, int *errorCode));
-static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_WideInt offset, int mode, int *errorCode));
-static void FileSetupProc _ANSI_ARGS_((ClientData clientData,
- int flags));
-static void FileWatchProc _ANSI_ARGS_((ClientData instanceData,
- int mask));
-static void FileThreadActionProc _ANSI_ARGS_ ((
- ClientData instanceData, int action));
-static int FileTruncateProc _ANSI_ARGS_ ((
- ClientData instanceData, Tcl_WideInt length));
+static int FileBlockProc(ClientData instanceData, int mode);
+static void FileChannelExitHandler(ClientData clientData);
+static void FileCheckProc(ClientData clientData, int flags);
+static int FileCloseProc(ClientData instanceData,
+ Tcl_Interp *interp);
+static int FileEventProc(Tcl_Event *evPtr, int flags);
+static int FileGetHandleProc(ClientData instanceData,
+ int direction, ClientData *handlePtr);
+static ThreadSpecificData *FileInit(void);
+static int FileInputProc(ClientData instanceData, char *buf,
+ int toRead, int *errorCode);
+static int FileOutputProc(ClientData instanceData,
+ CONST char *buf, int toWrite, int *errorCode);
+static int FileSeekProc(ClientData instanceData, long offset,
+ int mode, int *errorCode);
+static Tcl_WideInt FileWideSeekProc(ClientData instanceData,
+ Tcl_WideInt offset, int mode, int *errorCode);
+static void FileSetupProc(ClientData clientData, int flags);
+static void FileWatchProc(ClientData instanceData, int mask);
+static void FileThreadActionProc(ClientData instanceData,
+ int action);
+static int FileTruncateProc(ClientData instanceData,
+ Tcl_WideInt length);
/*
* This structure describes the channel type structure for file based IO.
@@ -128,23 +122,20 @@ static Tcl_ChannelType fileChannelType = {
};
#ifdef HAVE_NO_SEH
-
/*
- * Unlike Borland and Microsoft, we don't register exception handlers
- * by pushing registration records onto the runtime stack. Instead, we
- * register them by creating an EXCEPTION_REGISTRATION within the activation
- * record.
+ * Unlike Borland and Microsoft, we don't register exception handlers by
+ * pushing registration records onto the runtime stack. Instead, we register
+ * them by creating an EXCEPTION_REGISTRATION within the activation record.
*/
typedef struct EXCEPTION_REGISTRATION {
struct EXCEPTION_REGISTRATION* link;
- EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*,
- struct _CONTEXT*, void* );
+ EXCEPTION_DISPOSITION (*handler)(
+ struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*);
void* ebp;
void* esp;
int status;
} EXCEPTION_REGISTRATION;
-
#endif
/*
@@ -183,8 +174,8 @@ FileInit()
*
* FileChannelExitHandler --
*
- * This function is called to cleanup the channel driver before
- * Tcl is unloaded.
+ * This function is called to cleanup the channel driver before Tcl is
+ * unloaded.
*
* Results:
* None.
@@ -207,8 +198,8 @@ FileChannelExitHandler(clientData)
*
* FileSetupProc --
*
- * This procedure is invoked before Tcl_DoOneEvent blocks waiting
- * for an event.
+ * This function is invoked before Tcl_DoOneEvent blocks waiting for an
+ * event.
*
* Results:
* None.
@@ -221,9 +212,8 @@ FileChannelExitHandler(clientData)
void
FileSetupProc(data, flags)
- ClientData data; /* Not used. */
- int flags; /* Event flags as passed to
- * Tcl_DoOneEvent. */
+ ClientData data; /* Not used. */
+ int flags; /* Event flags as passed to Tcl_DoOneEvent. */
{
FileInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
@@ -234,7 +224,7 @@ FileSetupProc(data, flags)
}
/*
- * Check to see if there is a ready file. If so, poll.
+ * Check to see if there is a ready file. If so, poll.
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
@@ -251,8 +241,8 @@ FileSetupProc(data, flags)
*
* FileCheckProc --
*
- * This procedure is called by Tcl_DoOneEvent to check the file
- * event source for events.
+ * This function is called by Tcl_DoOneEvent to check the file event
+ * source for events.
*
* Results:
* None.
@@ -265,9 +255,8 @@ FileSetupProc(data, flags)
static void
FileCheckProc(data, flags)
- ClientData data; /* Not used. */
- int flags; /* Event flags as passed to
- * Tcl_DoOneEvent. */
+ ClientData data; /* Not used. */
+ int flags; /* Event flags as passed to Tcl_DoOneEvent. */
{
FileEvent *evPtr;
FileInfo *infoPtr;
@@ -278,9 +267,8 @@ FileCheckProc(data, flags)
}
/*
- * Queue events for any ready files that don't already have events
- * queued (caused by persistent states that won't generate WinSock
- * events).
+ * Queue events for any ready files that don't already have events queued
+ * (caused by persistent states that won't generate WinSock events).
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
@@ -300,15 +288,15 @@ FileCheckProc(data, flags)
*
* FileEventProc --
*
- * This function is invoked by Tcl_ServiceEvent when a file event
- * reaches the front of the event queue. This procedure invokes
- * Tcl_NotifyChannel on the file.
+ * This function is invoked by Tcl_ServiceEvent when a file event reaches
+ * the front of the event queue. This function invokes Tcl_NotifyChannel
+ * on the file.
*
* 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_FILE_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_FILE_EVENTS flag bit isn't set.
*
* Side effects:
* Whatever the notifier callback does.
@@ -318,9 +306,9 @@ FileCheckProc(data, flags)
static int
FileEventProc(evPtr, flags)
- Tcl_Event *evPtr; /* Event to service. */
- int flags; /* Flags that indicate what events to
- * handle, such as TCL_FILE_EVENTS. */
+ Tcl_Event *evPtr; /* Event to service. */
+ int flags; /* Flags that indicate what events to handle,
+ * such as TCL_FILE_EVENTS. */
{
FileEvent *fileEvPtr = (FileEvent *)evPtr;
FileInfo *infoPtr;
@@ -332,9 +320,9 @@ FileEventProc(evPtr, flags)
/*
* Search through the list of watched files for the one whose handle
- * matches the event. We do this rather than simply dereferencing
- * the handle in the event so that files can be deleted while the
- * event is in the queue.
+ * matches the event. We do this rather than simply dereferencing the
+ * handle in the event so that files can be deleted while the event is in
+ * the queue.
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
@@ -366,9 +354,9 @@ FileEventProc(evPtr, flags)
static int
FileBlockProc(instanceData, mode)
- ClientData instanceData; /* Instance data for channel. */
- int mode; /* TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
+ ClientData instanceData; /* Instance data for channel. */
+ int mode; /* TCL_MODE_BLOCKING or
+ * TCL_MODE_NONBLOCKING. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
@@ -405,8 +393,8 @@ FileBlockProc(instanceData, mode)
static int
FileCloseProc(instanceData, interp)
- ClientData instanceData; /* Pointer to FileInfo structure. */
- Tcl_Interp *interp; /* Not used. */
+ ClientData instanceData; /* Pointer to FileInfo structure. */
+ Tcl_Interp *interp; /* Not used. */
{
FileInfo *fileInfoPtr = (FileInfo *) instanceData;
FileInfo *infoPtr;
@@ -420,9 +408,9 @@ FileCloseProc(instanceData, interp)
FileWatchProc(instanceData, 0);
/*
- * Don't close the Win32 handle if the handle is a standard channel
- * during the thread exit process. Otherwise, one thread may kill
- * the stdio of another.
+ * Don't close the Win32 handle if the handle is a standard channel during
+ * the thread exit process. Otherwise, one thread may kill the stdio of
+ * another.
*/
if (!TclInThreadExit()
@@ -438,19 +426,21 @@ FileCloseProc(instanceData, interp)
/*
* See if this FileInfo* is still on the thread local list.
*/
+
tsdPtr = TCL_TSD_INIT(&dataKey);
- for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
+ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr == fileInfoPtr) {
- /*
- * This channel exists on the thread local list. It should
- * have been removed by an earlier Threadaction call,
- * but do that now since just deallocating fileInfoPtr would
- * leave an deallocated pointer on the thread local list.
- */
+ /*
+ * This channel exists on the thread local list. It should have
+ * been removed by an earlier Threadaction call, but do that now
+ * since just deallocating fileInfoPtr would leave an deallocated
+ * pointer on the thread local list.
+ */
+
FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE);
- break;
- }
+ break;
+ }
}
ckfree((char *)fileInfoPtr);
return errorCode;
@@ -464,22 +454,22 @@ FileCloseProc(instanceData, interp)
* Seeks on a file-based channel. Returns the new position.
*
* Results:
- * -1 if failed, the new position if successful. If failed, it
- * also sets *errorCodePtr to the error code.
+ * -1 if failed, the new position if successful. If failed, it also sets
+ * *errorCodePtr to the error code.
*
* Side effects:
- * Moves the location at which the channel will be accessed in
- * future operations.
+ * Moves the location at which the channel will be accessed in future
+ * operations.
*
*----------------------------------------------------------------------
*/
static int
FileSeekProc(instanceData, offset, mode, errorCodePtr)
- ClientData instanceData; /* File state. */
- long offset; /* Offset to seek to. */
- int mode; /* Relative to where should we seek? */
- int *errorCodePtr; /* To store error code. */
+ ClientData instanceData; /* File state. */
+ long offset; /* Offset to seek to. */
+ int mode; /* Relative to where should we seek? */
+ int *errorCodePtr; /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
@@ -497,6 +487,7 @@ FileSeekProc(instanceData, offset, mode, errorCodePtr)
/*
* Save our current place in case we need to roll-back the seek.
*/
+
oldPosHigh = 0;
oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
if (oldPos == INVALID_SET_FILE_POINTER) {
@@ -524,6 +515,7 @@ FileSeekProc(instanceData, offset, mode, errorCodePtr)
/*
* Check for expressability in our return type, and roll-back otherwise.
*/
+
if (newPosHigh != 0) {
*errorCodePtr = EOVERFLOW;
SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
@@ -540,22 +532,22 @@ FileSeekProc(instanceData, offset, mode, errorCodePtr)
* Seeks on a file-based channel. Returns the new position.
*
* Results:
- * -1 if failed, the new position if successful. If failed, it
- * also sets *errorCodePtr to the error code.
+ * -1 if failed, the new position if successful. If failed, it also sets
+ * *errorCodePtr to the error code.
*
* Side effects:
- * Moves the location at which the channel will be accessed in
- * future operations.
+ * Moves the location at which the channel will be accessed in future
+ * operations.
*
*----------------------------------------------------------------------
*/
static Tcl_WideInt
FileWideSeekProc(instanceData, offset, mode, errorCodePtr)
- ClientData instanceData; /* File state. */
- Tcl_WideInt offset; /* Offset to seek to. */
- int mode; /* Relative to where should we seek? */
- int *errorCodePtr; /* To store error code. */
+ ClientData instanceData; /* File state. */
+ Tcl_WideInt offset; /* Offset to seek to. */
+ int mode; /* Relative to where should we seek? */
+ int *errorCodePtr; /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
DWORD moveMethod;
@@ -603,8 +595,8 @@ FileWideSeekProc(instanceData, offset, mode, errorCodePtr)
static int
FileTruncateProc(instanceData, length)
- ClientData instanceData; /* File state. */
- Tcl_WideInt length; /* Length to truncate at. */
+ ClientData instanceData; /* File state. */
+ Tcl_WideInt length; /* Length to truncate at. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
@@ -612,6 +604,7 @@ FileTruncateProc(instanceData, length)
/*
* Save where we were...
*/
+
oldPosHigh = 0;
oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
if (oldPos == INVALID_SET_FILE_POINTER) {
@@ -625,6 +618,7 @@ FileTruncateProc(instanceData, length)
/*
* Move to where we want to truncate
*/
+
newPosHigh = Tcl_WideAsLong(length >> 32);
newPos = SetFilePointer(infoPtr->handle, Tcl_WideAsLong(length),
&newPosHigh, FILE_BEGIN);
@@ -637,21 +631,21 @@ FileTruncateProc(instanceData, length)
}
/*
- * Perform the truncation (unlike POSIX ftruncate(), we needed to
- * move to the location to truncate at first).
+ * Perform the truncation (unlike POSIX ftruncate(), we needed to move to
+ * the location to truncate at first).
*/
+
if (!SetEndOfFile(infoPtr->handle)) {
TclWinConvertError(GetLastError());
return errno;
}
/*
- * Move back. If this last step fails, we don't care; it's just a
- * "best effort" attempt to restore our file pointer to where it
- * was.
+ * Move back. If this last step fails, we don't care; it's just a "best
+ * effort" attempt to restore our file pointer to where it was.
*/
- SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
+ SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
return 0;
}
@@ -660,8 +654,8 @@ FileTruncateProc(instanceData, length)
*
* FileInputProc --
*
- * Reads input from the IO channel into the buffer given. Returns
- * count of how many bytes were actually read, and an error indication.
+ * Reads input from the IO channel into the buffer given. Returns count
+ * of how many bytes were actually read, and an error indication.
*
* Results:
* A count of how many bytes were read is returned and an error
@@ -675,10 +669,10 @@ FileTruncateProc(instanceData, length)
static int
FileInputProc(instanceData, buf, bufSize, errorCode)
- ClientData instanceData; /* File state. */
- char *buf; /* Where to store data read. */
- int bufSize; /* Num bytes available in buffer. */
- int *errorCode; /* Where to store error code. */
+ ClientData instanceData; /* File state. */
+ char *buf; /* Where to store data read. */
+ int bufSize; /* Num bytes available in buffer. */
+ int *errorCode; /* Where to store error code. */
{
FileInfo *infoPtr;
DWORD bytesRead;
@@ -687,11 +681,11 @@ FileInputProc(instanceData, buf, bufSize, errorCode)
infoPtr = (FileInfo *) instanceData;
/*
- * Note that we will block on reads from a console buffer until a
- * full line has been entered. The only way I know of to get
- * around this is to write a console driver. We should probably
- * do this at some point, but for now, we just block. The same
- * problem exists for files being read over the network.
+ * Note that we will block on reads from a console buffer until a full
+ * line has been entered. The only way I know of to get around this is to
+ * write a console driver. We should probably do this at some point, but
+ * for now, we just block. The same problem exists for files being read
+ * over the network.
*/
if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
@@ -712,12 +706,12 @@ FileInputProc(instanceData, buf, bufSize, errorCode)
*
* FileOutputProc --
*
- * Writes the given output on the IO channel. Returns count of how
- * many characters were actually written, and an error indication.
+ * Writes the given output on the IO channel. Returns count of how many
+ * characters were actually written, and an error indication.
*
* Results:
- * A count of how many characters were written is returned and an
- * error indication is returned in an output argument.
+ * A count of how many characters were written is returned and an error
+ * indication is returned in an output argument.
*
* Side effects:
* Writes output on the actual channel.
@@ -727,10 +721,10 @@ FileInputProc(instanceData, buf, bufSize, errorCode)
static int
FileOutputProc(instanceData, buf, toWrite, errorCode)
- ClientData instanceData; /* File state. */
- CONST char *buf; /* The data buffer. */
- int toWrite; /* How many bytes to write? */
- int *errorCode; /* Where to store error code. */
+ ClientData instanceData; /* File state. */
+ CONST char *buf; /* The data buffer. */
+ int toWrite; /* How many bytes to write? */
+ int *errorCode; /* Where to store error code. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
DWORD bytesWritten;
@@ -761,8 +755,7 @@ FileOutputProc(instanceData, buf, toWrite, errorCode)
*
* FileWatchProc --
*
- * Called by the notifier to set up to watch for events on this
- * channel.
+ * Called by the notifier to set up to watch for events on this channel.
*
* Results:
* None.
@@ -775,17 +768,17 @@ FileOutputProc(instanceData, buf, toWrite, errorCode)
static void
FileWatchProc(instanceData, mask)
- ClientData instanceData; /* File state. */
- int mask; /* What events to watch for; OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
+ ClientData instanceData; /* File state. */
+ int mask; /* What events to watch for; OR-ed combination
+ * of TCL_READABLE, TCL_WRITABLE and
+ * TCL_EXCEPTION. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
Tcl_Time blockTime = { 0, 0 };
/*
- * Since the file is always ready for events, we set the block time
- * to zero so we will poll.
+ * Since the file is always ready for events, we set the block time to
+ * zero so we will poll.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
@@ -799,12 +792,12 @@ FileWatchProc(instanceData, mask)
*
* FileGetHandleProc --
*
- * Called from Tcl_GetChannelHandle to retrieve OS handles from
- * a file based channel.
+ * Called from Tcl_GetChannelHandle to retrieve OS handles from a file
+ * based channel.
*
* Results:
- * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
- * there is no handle for the specified direction.
+ * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
+ * handle for the specified direction.
*
* Side effects:
* None.
@@ -814,9 +807,9 @@ FileWatchProc(instanceData, mask)
static int
FileGetHandleProc(instanceData, direction, handlePtr)
- ClientData instanceData; /* The file state. */
- int direction; /* TCL_READABLE or TCL_WRITABLE */
- ClientData *handlePtr; /* Where to store the handle. */
+ ClientData instanceData; /* The file state. */
+ int direction; /* TCL_READABLE or TCL_WRITABLE */
+ ClientData *handlePtr; /* Where to store the handle. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
@@ -836,25 +829,24 @@ FileGetHandleProc(instanceData, direction, handlePtr)
* Open an File based channel on Unix systems.
*
* Results:
- * The new channel or NULL. If NULL, the output argument
- * errorCodePtr is set to a POSIX error.
+ * The new channel or NULL. If NULL, the output argument errorCodePtr is
+ * set to a POSIX error.
*
* Side effects:
- * May open the channel and may cause creation of a file on the
- * file system.
+ * May open the channel and may cause creation of a file on the file
+ * system.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
- Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- Tcl_Obj *pathPtr; /* Name of file to open. */
- int mode; /* POSIX mode. */
- int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
+ Tcl_Interp *interp; /* Interpreter for error reporting; can be
+ * NULL. */
+ Tcl_Obj *pathPtr; /* Name of file to open. */
+ int mode; /* POSIX mode. */
+ int permissions; /* If the open involves creating a file, with
+ * what modes to create it? */
{
Tcl_Channel channel = 0;
int channelPermissions;
@@ -939,7 +931,7 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions)
* Now we get to create the file.
*/
- handle = (*tclWinProcs->createFileProc)(nativeName, accessMode,
+ handle = (*tclWinProcs->createFileProc)(nativeName, accessMode,
shareMode, NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
@@ -959,9 +951,9 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions)
type = GetFileType(handle);
/*
- * If the file is a character device, we need to try to figure out
- * whether it is a serial port, a console, or something else. We
- * test for the console case first because this is more common.
+ * If the file is a character device, we need to try to figure out whether
+ * it is a serial port, a console, or something else. We test for the
+ * console case first because this is more common.
*/
if (type == FILE_TYPE_CHAR) {
@@ -982,9 +974,10 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions)
switch (type) {
case FILE_TYPE_SERIAL:
/*
- * Reopen channel for OVERLAPPED operation
- * Normally this shouldn't fail, because the channel exists
+ * Reopen channel for OVERLAPPED operation. Normally this shouldn't
+ * fail, because the channel exists.
*/
+
handle = TclWinSerialReopen(handle, nativeName, accessMode);
if (handle == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
@@ -1020,8 +1013,8 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions)
default:
/*
- * The handle is of an unknown type, probably /dev/nul equivalent
- * or possibly a closed handle.
+ * The handle is of an unknown type, probably /dev/nul equivalent or
+ * possibly a closed handle.
*/
channel = NULL;
@@ -1038,8 +1031,7 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions)
*
* Tcl_MakeFileChannel --
*
- * Creates a Tcl_Channel from an existing platform specific file
- * handle.
+ * Creates a Tcl_Channel from an existing platform specific file handle.
*
* Results:
* The Tcl_Channel created around the preexisting file.
@@ -1052,10 +1044,9 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions)
Tcl_Channel
Tcl_MakeFileChannel(rawHandle, mode)
- ClientData rawHandle; /* OS level handle */
- int mode; /* ORed combination of TCL_READABLE
- * and TCL_WRITABLE to indicate file
- * mode. */
+ ClientData rawHandle; /* OS level handle */
+ int mode; /* ORed combination of TCL_READABLE and
+ * TCL_WRITABLE to indicate file mode. */
{
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
@@ -1079,9 +1070,9 @@ Tcl_MakeFileChannel(rawHandle, mode)
type = GetFileType(handle);
/*
- * If the file is a character device, we need to try to figure out
- * whether it is a serial port, a console, or something else. We
- * test for the console case first because this is more common.
+ * If the file is a character device, we need to try to figure out whether
+ * it is a serial port, a console, or something else. We test for the
+ * console case first because this is more common.
*/
if (type == FILE_TYPE_CHAR) {
@@ -1122,10 +1113,10 @@ Tcl_MakeFileChannel(rawHandle, mode)
case FILE_TYPE_UNKNOWN:
default:
/*
- * The handle is of an unknown type. Test the validity of this OS
- * handle by duplicating it, then closing the dupe. The Win32 API
+ * The handle is of an unknown type. Test the validity of this OS
+ * handle by duplicating it, then closing the dupe. The Win32 API
* doesn't provide an IsValidHandle() function, so we have to emulate
- * it here. This test will not work on a console handle reliably,
+ * it here. This test will not work on a console handle reliably,
* which is why we can't test every handle that comes into this
* function in this way.
*/
@@ -1156,12 +1147,11 @@ Tcl_MakeFileChannel(rawHandle, mode)
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#else
/*
- * Don't have SEH available, do things the hard way.
- * Note that this needs to be one block of asm, to avoid stack
- * imbalance; also, it is illegal for one asm block to contain
- * a jump to another.
+ * Don't have SEH available, do things the hard way. Note that this
+ * needs to be one block of asm, to avoid stack imbalance; also, it is
+ * illegal for one asm block to contain a jump to another.
*/
-
+
__asm__ __volatile__ (
/*
@@ -1171,9 +1161,10 @@ Tcl_MakeFileChannel(rawHandle, mode)
"movl %[dupedHandle], %%ebx" "\n\t"
/*
- * Construct an EXCEPTION_REGISTRATION to protect the
- * call to CloseHandle
+ * Construct an EXCEPTION_REGISTRATION to protect the call to
+ * CloseHandle.
*/
+
"leal %[registration], %%edx" "\n\t"
"movl %%fs:0, %%eax" "\n\t"
"movl %%eax, 0x0(%%edx)" "\n\t" /* link */
@@ -1182,45 +1173,49 @@ Tcl_MakeFileChannel(rawHandle, mode)
"movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
"movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
"movl $0, 0x10(%%edx)" "\n\t" /* status */
-
- /* Link the EXCEPTION_REGISTRATION on the chain */
-
+
+ /*
+ * Link the EXCEPTION_REGISTRATION on the chain.
+ */
+
"movl %%edx, %%fs:0" "\n\t"
-
- /* Call CloseHandle( dupedHandle ) */
-
+
+ /*
+ * Call CloseHandle(dupedHandle).
+ */
+
"pushl %%ebx" "\n\t"
"call _CloseHandle@4" "\n\t"
-
- /*
- * Come here on normal exit. Recover the EXCEPTION_REGISTRATION
+
+ /*
+ * Come here on normal exit. Recover the EXCEPTION_REGISTRATION
* and put a TRUE status return into it.
*/
-
+
"movl %%fs:0, %%edx" "\n\t"
"movl $1, %%eax" "\n\t"
"movl %%eax, 0x10(%%edx)" "\n\t"
"jmp 2f" "\n"
-
+
/*
- * Come here on an exception. Recover the EXCEPTION_REGISTRATION
+ * Come here on an exception. Recover the EXCEPTION_REGISTRATION
*/
-
+
"1:" "\t"
"movl %%fs:0, %%edx" "\n\t"
"movl 0x8(%%edx), %%edx" "\n\t"
-
- /*
- * Come here however we exited. Restore context from the
+
+ /*
+ * Come here however we exited. Restore context from the
* EXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
-
+
"2:" "\t"
"movl 0xc(%%edx), %%esp" "\n\t"
"movl 0x8(%%edx), %%ebp" "\n\t"
"movl 0x0(%%edx), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
-
+
:
/* No outputs */
:
@@ -1236,9 +1231,9 @@ Tcl_MakeFileChannel(rawHandle, mode)
return NULL;
}
- /* Fall through, the handle is valid. */
-
/*
+ * Fall through, the handle is valid.
+ *
* Create the undefined channel, anyways, because we know the handle
* is valid to something.
*/
@@ -1260,16 +1255,15 @@ Tcl_MakeFileChannel(rawHandle, mode)
* Returns the specified default standard channel, or NULL.
*
* Side effects:
- * May cause the creation of a standard channel and the underlying
- * file.
+ * May cause the creation of a standard channel and the underlying file.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpGetDefaultStdChannel(type)
- int type; /* One of TCL_STDIN, TCL_STDOUT, or
- * TCL_STDERR. */
+ int type; /* One of TCL_STDIN, TCL_STDOUT, or
+ * TCL_STDERR. */
{
Tcl_Channel channel;
HANDLE handle;
@@ -1334,31 +1328,30 @@ TclpGetDefaultStdChannel(type)
*
* TclWinOpenFileChannel --
*
- * Constructs a File channel for the specified standard OS handle.
- * This is a helper function to break up the construction of
- * channels into File, Console, or Serial.
+ * Constructs a File channel for the specified standard OS handle. This
+ * is a helper function to break up the construction of channels into
+ * File, Console, or Serial.
*
* Results:
* Returns the new channel, or NULL.
*
* Side effects:
- * May open the channel and may cause creation of a file on the
- * file system.
+ * May open the channel and may cause creation of a file on the file
+ * system.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclWinOpenFileChannel(handle, channelName, permissions, appendMode)
- HANDLE handle; /* Win32 HANDLE to swallow */
- char *channelName; /* Buffer to receive channel name */
- int permissions; /* OR'ed combination of TCL_READABLE,
- * TCL_WRITABLE, or TCL_EXCEPTION,
- * indicating which operations are
- * valid on the file. */
- int appendMode; /* OR'ed combination of bits indicating
- * what additional configuration of the
- * channel is present. */
+ HANDLE handle; /* Win32 HANDLE to swallow */
+ char *channelName; /* Buffer to receive channel name */
+ int permissions; /* OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, or TCL_EXCEPTION, indicating
+ * which operations are valid on the file. */
+ int appendMode; /* OR'ed combination of bits indicating what
+ * additional configuration of the channel is
+ * present. */
{
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr = FileInit();
@@ -1375,10 +1368,13 @@ TclWinOpenFileChannel(handle, channelName, permissions, appendMode)
}
infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
- /* TIP #218. Removed the code inserting the new structure
- * into the global list. This is now handled in the thread
- * action callbacks, and only there.
+
+ /*
+ * TIP #218. Removed the code inserting the new structure into the global
+ * list. This is now handled in the thread action callbacks, and only
+ * there.
*/
+
infoPtr->nextPtr = NULL;
infoPtr->validMask = permissions;
infoPtr->watchMask = 0;
@@ -1391,8 +1387,8 @@ TclWinOpenFileChannel(handle, channelName, permissions, appendMode)
(ClientData) infoPtr, permissions);
/*
- * Files have default translation of AUTO and ^Z eof char, which
- * means that a ^Z will be accepted as EOF when reading.
+ * Files have default translation of AUTO and ^Z eof char, which means
+ * that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
@@ -1406,30 +1402,29 @@ TclWinOpenFileChannel(handle, channelName, permissions, appendMode)
*
* TclWinFlushDirtyChannels --
*
- * Flush all dirty channels to disk, so that requesting the
- * size of any file returns the correct value.
+ * Flush all dirty channels to disk, so that requesting the size of any
+ * file returns the correct value.
*
* Results:
* None.
*
* Side effects:
- * Information is actually written to disk now, rather than
- * later. Don't call this too often, or there will be a
- * performance hit (i.e. only call when we need to ask for
- * the size of a file).
+ * Information is actually written to disk now, rather than later. Don't
+ * call this too often, or there will be a performance hit (i.e. only
+ * call when we need to ask for the size of a file).
*
*----------------------------------------------------------------------
*/
void
-TclWinFlushDirtyChannels ()
+TclWinFlushDirtyChannels()
{
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr = FileInit();
/*
- * Flush all channels which are dirty, i.e. may have data pending
- * in the OS
+ * Flush all channels which are dirty, i.e. may have data pending in the
+ * OS.
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
@@ -1458,33 +1453,33 @@ TclWinFlushDirtyChannels ()
*/
static void
-FileThreadActionProc (instanceData, action)
- ClientData instanceData;
- int action;
+FileThreadActionProc(instanceData, action)
+ ClientData instanceData;
+ int action;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileInfo *infoPtr = (FileInfo *) instanceData;
if (action == TCL_CHANNEL_THREAD_INSERT) {
- infoPtr->nextPtr = tsdPtr->firstFilePtr;
+ infoPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = infoPtr;
} else {
- FileInfo **nextPtrPtr;
+ FileInfo **nextPtrPtr;
int removed = 0;
for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
- nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
+ nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == infoPtr) {
- (*nextPtrPtr) = infoPtr->nextPtr;
+ (*nextPtrPtr) = infoPtr->nextPtr;
removed = 1;
break;
}
}
/*
- * This could happen if the channel was created in one thread
- * and then moved to another without updating the thread
- * local data in each thread.
+ * This could happen if the channel was created in one thread and then
+ * moved to another without updating the thread local data in each
+ * thread.
*/
if (!removed) {
@@ -1492,3 +1487,11 @@ FileThreadActionProc (instanceData, action)
}
}
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c
index 2aa08b3..83ef862 100644
--- a/win/tclWinConsole.c
+++ b/win/tclWinConsole.c
@@ -1,15 +1,15 @@
/*
* tclWinConsole.c --
*
- * This file implements the Windows-specific console functions,
- * and the "console" channel driver.
+ * This file implements the Windows-specific console functions, and the
+ * "console" channel driver.
*
* Copyright (c) 1999 by Scriptics Corp.
*
- * 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: tclWinConsole.c,v 1.14 2005/05/10 18:35:37 kennykb Exp $
+ * RCS: @(#) $Id: tclWinConsole.c,v 1.15 2005/07/24 22:56:47 dkf Exp $
*/
#include "tclWinInt.h"
@@ -45,10 +45,11 @@ TCL_DECLARE_MUTEX(consoleMutex)
*/
#define CONSOLE_EOF (1<<2) /* Console has reached EOF. */
-#define CONSOLE_BUFFERED (1<<3) /* data was read into a buffer by the reader
- thread */
+#define CONSOLE_BUFFERED (1<<3) /* Data was read into a buffer by the reader
+ * thread. */
#define CONSOLE_BUFFER_SIZE (8*1024)
+
/*
* This structure describes per-instance data for a console based channel.
*/
@@ -71,50 +72,48 @@ typedef struct ConsoleInfo {
HANDLE writeThread; /* Handle to writer thread. */
HANDLE readThread; /* Handle to reader thread. */
HANDLE writable; /* Manual-reset event to signal when the
- * writer thread has finished waiting for
- * the current buffer to be written. */
+ * writer thread has finished waiting for the
+ * current buffer to be written. */
HANDLE readable; /* Manual-reset event to signal when the
* reader thread has finished waiting for
* input. */
HANDLE startWriter; /* Auto-reset event used by the main thread to
- * signal when the writer thread should attempt
- * to write to the console. */
+ * signal when the writer thread should
+ * attempt to write to the console. */
HANDLE stopWriter; /* Auto-reset event used by the main thread to
* signal when the writer thread should exit.
*/
HANDLE startReader; /* Auto-reset event used by the main thread to
- * signal when the reader thread should attempt
- * to read from the console. */
+ * signal when the reader thread should
+ * attempt to read from the console. */
HANDLE stopReader; /* Auto-reset event used by the main thread to
* signal when the reader thread should exit.
*/
DWORD writeError; /* An error caused by the last background
- * write. Set to 0 if no error has been
- * detected. This word is shared with the
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
* writer thread so access must be
* synchronized with the writable object.
*/
- char *writeBuf; /* Current background output buffer.
- * Access is synchronized with the writable
- * object. */
- int writeBufLen; /* Size of write buffer. Access is
- * synchronized with the writable
- * object. */
- int toWrite; /* Current amount to be written. Access is
+ char *writeBuf; /* Current background output buffer. Access is
+ * synchronized with the writable object. */
+ int writeBufLen; /* Size of write buffer. Access is
+ * synchronized with the writable object. */
+ int toWrite; /* Current amount to be written. Access is
* synchronized with the writable object. */
int readFlags; /* Flags that are shared with the reader
- * thread. Access is synchronized with the
- * readable object. */
- int bytesRead; /* number of bytes in the buffer */
- int offset; /* number of bytes read out of the buffer */
+ * thread. Access is synchronized with the
+ * readable object. */
+ int bytesRead; /* number of bytes in the buffer */
+ int offset; /* number of bytes read out of the buffer */
char buffer[CONSOLE_BUFFER_SIZE];
- /* Data consumed by reader thread. */
+ /* Data consumed by reader thread. */
} ConsoleInfo;
typedef struct ThreadSpecificData {
/*
- * The following pointer refers to the head of the list of consoles
- * that are being watched for file events.
+ * The following pointer refers to the head of the list of consoles that
+ * are being watched for file events.
*/
ConsoleInfo *firstConsolePtr;
@@ -128,9 +127,9 @@ static Tcl_ThreadDataKey dataKey;
*/
typedef struct ConsoleEvent {
- Tcl_Event header; /* Information that is standard for
- * all events. */
- ConsoleInfo *infoPtr; /* Pointer to console info structure. Note
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ ConsoleInfo *infoPtr; /* Pointer to console info structure. Note
* that we still have to verify that the
* console exists before dereferencing this
* pointer. */
@@ -148,7 +147,7 @@ static int ConsoleEventProc(Tcl_Event *evPtr, int flags);
static void ConsoleExitHandler(ClientData clientData);
static int ConsoleGetHandleProc(ClientData instanceData,
int direction, ClientData *handlePtr);
-static void ConsoleInit(void);
+static void ConsoleInit(void);
static int ConsoleInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
static int ConsoleOutputProc(ClientData instanceData,
@@ -159,9 +158,8 @@ static void ConsoleWatchProc(ClientData instanceData, int mask);
static DWORD WINAPI ConsoleWriterThread(LPVOID arg);
static void ProcExitHandler(ClientData clientData);
static int WaitForRead(ConsoleInfo *infoPtr, int blocking);
-
-static void ConsoleThreadActionProc _ANSI_ARGS_ ((
- ClientData instanceData, int action));
+static void ConsoleThreadActionProc(ClientData instanceData,
+ int action);
/*
* This structure describes the channel type structure for command console
@@ -183,7 +181,7 @@ static Tcl_ChannelType consoleChannelType = {
ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
- NULL, /* wide seek proc */
+ NULL, /* wide seek proc */
ConsoleThreadActionProc, /* thread action proc */
};
@@ -209,8 +207,8 @@ ConsoleInit()
ThreadSpecificData *tsdPtr;
/*
- * Check the initialized flag first, then check again in the mutex.
- * This is a speed enhancement.
+ * Check the initialized flag first, then check again in the mutex. This
+ * is a speed enhancement.
*/
if (!initialized) {
@@ -236,8 +234,8 @@ ConsoleInit()
*
* ConsoleExitHandler --
*
- * This function is called to cleanup the console module before
- * Tcl is unloaded.
+ * This function is called to cleanup the console module before Tcl is
+ * unloaded.
*
* Results:
* None.
@@ -260,8 +258,8 @@ ConsoleExitHandler(
*
* ProcExitHandler --
*
- * This function is called to cleanup the process list before
- * Tcl is unloaded.
+ * This function is called to cleanup the process list before Tcl is
+ * unloaded.
*
* Results:
* None.
@@ -286,8 +284,8 @@ ProcExitHandler(
*
* ConsoleSetupProc --
*
- * This procedure is invoked before Tcl_DoOneEvent blocks waiting
- * for an event.
+ * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an
+ * event.
*
* Results:
* None.
@@ -313,7 +311,7 @@ ConsoleSetupProc(
}
/*
- * Look to see if any events are already pending. If they are, poll.
+ * Look to see if any events are already pending. If they are, poll.
*/
for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
@@ -339,8 +337,8 @@ ConsoleSetupProc(
*
* ConsoleCheckProc --
*
- * This procedure is called by Tcl_DoOneEvent to check the console
- * event source for events.
+ * This procedure is called by Tcl_DoOneEvent to check the console event
+ * source for events.
*
* Results:
* None.
@@ -424,15 +422,16 @@ static int
ConsoleBlockModeProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
+ * TCL_MODE_NONBLOCKING. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
/*
- * Consoles on Windows can not be switched between blocking and nonblocking,
- * hence we have to emulate the behavior. This is done in the input
- * function by checking against a bit in the state. We set or unset the
- * bit here to cause the input function to emulate the correct behavior.
+ * Consoles on Windows can not be switched between blocking and
+ * nonblocking, hence we have to emulate the behavior. This is done in the
+ * input function by checking against a bit in the state. We set or unset
+ * the bit here to cause the input function to emulate the correct
+ * behavior.
*/
if (mode == TCL_MODE_NONBLOCKING) {
@@ -473,25 +472,23 @@ ConsoleCloseProc(
errorCode = 0;
/*
- * Clean up the background thread if necessary. Note that this
- * must be done before we can close the file, since the
- * thread may be blocking trying to read from the console.
+ * Clean up the background thread if necessary. Note that this must be
+ * done before we can close the file, since the thread may be blocking
+ * trying to read from the console.
*/
if (consolePtr->readThread) {
-
/*
- * The thread may already have closed on it's own. Check it's
- * exit code.
+ * The thread may already have closed on it's own. Check it's exit
+ * code.
*/
GetExitCodeThread(consolePtr->readThread, &exitCode);
if (exitCode == STILL_ACTIVE) {
-
/*
- * Set the stop event so that if the reader thread is blocked
- * in ConsoleReaderThread on WaitForMultipleEvents, it will exit
+ * Set the stop event so that if the reader thread is blocked in
+ * ConsoleReaderThread on WaitForMultipleEvents, it will exit
* cleanly.
*/
@@ -504,11 +501,10 @@ ConsoleCloseProc(
if (WaitForSingleObject(consolePtr->readThread, 20)
== WAIT_TIMEOUT) {
/*
- * Forcibly terminate the background thread as a last
- * resort. Note that we need to guard against
- * terminating the thread while it is in the middle of
- * Tcl_ThreadAlert because it won't be able to release
- * the notifier lock.
+ * Forcibly terminate the background thread as a last resort.
+ * Note that we need to guard against terminating the thread
+ * while it is in the middle of Tcl_ThreadAlert because it
+ * won't be able to release the notifier lock.
*/
Tcl_MutexLock(&consoleMutex);
@@ -528,32 +524,33 @@ ConsoleCloseProc(
consolePtr->validMask &= ~TCL_READABLE;
/*
- * Wait for the writer thread to finish the current buffer, then
- * terminate the thread and close the handles. If the channel is
- * nonblocking, there should be no pending write operations.
+ * Wait for the writer thread to finish the current buffer, then terminate
+ * the thread and close the handles. If the channel is nonblocking, there
+ * should be no pending write operations.
*/
if (consolePtr->writeThread) {
if (consolePtr->toWrite) {
/*
- * We only need to wait if there is something to write.
- * This may prevent infinite wait on exit. [python bug 216289]
+ * We only need to wait if there is something to write. This may
+ * prevent infinite wait on exit. [python bug 216289]
*/
+
WaitForSingleObject(consolePtr->writable, INFINITE);
}
/*
- * The thread may already have closed on it's own. Check it's
- * exit code.
+ * The thread may already have closed on it's own. Check it's exit
+ * code.
*/
GetExitCodeThread(consolePtr->writeThread, &exitCode);
if (exitCode == STILL_ACTIVE) {
/*
- * Set the stop event so that if the reader thread is blocked
- * in ConsoleWriterThread on WaitForMultipleEvents, it will
- * exit cleanly.
+ * Set the stop event so that if the reader thread is blocked in
+ * ConsoleWriterThread on WaitForMultipleEvents, it will exit
+ * cleanly.
*/
SetEvent(consolePtr->stopWriter);
@@ -565,11 +562,10 @@ ConsoleCloseProc(
if (WaitForSingleObject(consolePtr->writeThread, 20)
== WAIT_TIMEOUT) {
/*
- * Forcibly terminate the background thread as a last
- * resort. Note that we need to guard against
- * terminating the thread while it is in the middle of
- * Tcl_ThreadAlert because it won't be able to release
- * the notifier lock.
+ * Forcibly terminate the background thread as a last resort.
+ * Note that we need to guard against terminating the thread
+ * while it is in the middle of Tcl_ThreadAlert because it
+ * won't be able to release the notifier lock.
*/
Tcl_MutexLock(&consoleMutex);
@@ -590,9 +586,9 @@ ConsoleCloseProc(
/*
- * Don't close the Win32 handle if the handle is a standard channel
- * during the thread exit process. Otherwise, one thread may kill
- * the stdio of another.
+ * Don't close the Win32 handle if the handle is a standard channel during
+ * the thread exit process. Otherwise, one thread may kill the stdio of
+ * another.
*/
if (!TclInThreadExit()
@@ -633,8 +629,8 @@ ConsoleCloseProc(
*
* ConsoleInputProc --
*
- * Reads input from the IO channel into the buffer given. Returns
- * count of how many bytes were actually read, and an error indication.
+ * Reads input from the IO channel into the buffer given. Returns count
+ * of how many bytes were actually read, and an error indication.
*
* Results:
* A count of how many bytes were read is returned and an error
@@ -648,11 +644,11 @@ ConsoleCloseProc(
static int
ConsoleInputProc(
- ClientData instanceData, /* Console state. */
- char *buf, /* Where to store data read. */
- int bufSize, /* How much space is available
- * in the buffer? */
- int *errorCode) /* Where to store error code. */
+ ClientData instanceData, /* Console state. */
+ char *buf, /* Where to store data read. */
+ int bufSize, /* How much space is available in the
+ * buffer? */
+ int *errorCode) /* Where to store error code. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
DWORD count, bytesRead = 0;
@@ -700,13 +696,13 @@ ConsoleInputProc(
}
/*
- * Attempt to read bufSize bytes. The read will return immediately
- * if there is any data available. Otherwise it will block until
- * at least one byte is available or an EOF occurs.
+ * Attempt to read bufSize bytes. The read will return immediately if
+ * there is any data available. Otherwise it will block until at least one
+ * byte is available or an EOF occurs.
*/
if (ReadConsole(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count,
- (LPOVERLAPPED) NULL) == TRUE) {
+ (LPOVERLAPPED) NULL) == TRUE) {
buf[count] = '\0';
return count;
}
@@ -719,12 +715,12 @@ ConsoleInputProc(
*
* ConsoleOutputProc --
*
- * Writes the given output on the IO channel. Returns count of how
- * many characters were actually written, and an error indication.
+ * Writes the given output on the IO channel. Returns count of how many
+ * characters were actually written, and an error indication.
*
* Results:
- * A count of how many characters were written is returned and an
- * error indication is returned in an output argument.
+ * A count of how many characters were written is returned and an error
+ * indication is returned in an output argument.
*
* Side effects:
* Writes output on the actual channel.
@@ -746,8 +742,8 @@ ConsoleOutputProc(
timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE;
if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
/*
- * The writer thread is blocked waiting for a write to complete
- * and the channel is in non-blocking mode.
+ * The writer thread is blocked waiting for a write to complete and
+ * the channel is in non-blocking mode.
*/
errno = EAGAIN;
@@ -788,8 +784,8 @@ ConsoleOutputProc(
bytesWritten = toWrite;
} else {
/*
- * In the blocking case, just try to write the buffer directly.
- * This avoids an unnecessary copy.
+ * In the blocking case, just try to write the buffer directly. This
+ * avoids an unnecessary copy.
*/
if (WriteConsole(infoPtr->handle, buf, toWrite, &bytesWritten,
@@ -800,7 +796,7 @@ ConsoleOutputProc(
}
return bytesWritten;
-error:
+ error:
*errorCode = errno;
return -1;
}
@@ -810,15 +806,15 @@ error:
*
* ConsoleEventProc --
*
- * This function is invoked by Tcl_ServiceEvent when a file event
- * reaches the front of the event queue. This procedure invokes
- * Tcl_NotifyChannel on the console.
+ * This function is invoked by Tcl_ServiceEvent when a file event reaches
+ * the front of the event queue. This procedure invokes Tcl_NotifyChannel
+ * on the console.
*
* 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_FILE_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_FILE_EVENTS flag bit isn't set.
*
* Side effects:
* Whatever the notifier callback does.
@@ -829,8 +825,8 @@ error:
static int
ConsoleEventProc(
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. */
{
ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr;
ConsoleInfo *infoPtr;
@@ -843,9 +839,9 @@ ConsoleEventProc(
/*
* Search through the list of watched consoles for the one whose handle
- * matches the event. We do this rather than simply dereferencing
- * the handle in the event so that consoles can be deleted while the
- * event is in the queue.
+ * matches the event. We do this rather than simply dereferencing the
+ * handle in the event so that consoles can be deleted while the event is
+ * in the queue.
*/
for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
@@ -865,9 +861,9 @@ ConsoleEventProc(
}
/*
- * Check to see if the console is readable. Note
- * that we can't tell if a console is writable, so we always report it
- * as being writable unless we have detected EOF.
+ * Check to see if the console is readable. Note that we can't tell if a
+ * console is writable, so we always report it as being writable unless we
+ * have detected EOF.
*/
mask = 0;
@@ -900,8 +896,7 @@ ConsoleEventProc(
*
* ConsoleWatchProc --
*
- * Called by the notifier to set up to watch for events on this
- * channel.
+ * Called by the notifier to set up to watch for events on this channel.
*
* Results:
* None.
@@ -914,10 +909,10 @@ ConsoleEventProc(
static void
ConsoleWatchProc(
- ClientData instanceData, /* Console state. */
- int mask) /* What events to watch for, OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
+ ClientData instanceData, /* Console state. */
+ int mask) /* What events to watch for, OR-ed combination
+ * of TCL_READABLE, TCL_WRITABLE and
+ * TCL_EXCEPTION. */
{
ConsoleInfo **nextPtrPtr, *ptr;
ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
@@ -925,9 +920,8 @@ ConsoleWatchProc(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * Since most of the work is handled by the background threads,
- * we just need to update the watchMask and then force the notifier
- * to poll once.
+ * Since most of the work is handled by the background threads, we just
+ * need to update the watchMask and then force the notifier to poll once.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
@@ -938,19 +932,17 @@ ConsoleWatchProc(
tsdPtr->firstConsolePtr = infoPtr;
}
Tcl_SetMaxBlockTime(&blockTime);
- } else {
- if (oldMask) {
- /*
- * Remove the console from the list of watched consoles.
- */
+ } else if (oldMask) {
+ /*
+ * Remove the console from the list of watched consoles.
+ */
- for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr;
- ptr != NULL;
- nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
- if (infoPtr == ptr) {
- *nextPtrPtr = ptr->nextPtr;
- break;
- }
+ for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr;
+ ptr != NULL;
+ nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
+ if (infoPtr == ptr) {
+ *nextPtrPtr = ptr->nextPtr;
+ break;
}
}
}
@@ -961,12 +953,12 @@ ConsoleWatchProc(
*
* ConsoleGetHandleProc --
*
- * Called from Tcl_GetChannelHandle to retrieve OS handles from
- * inside a command consoleline based channel.
+ * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
+ * command consoleline based channel.
*
* Results:
- * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
- * there is no handle for the specified direction.
+ * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
+ * handle for the specified direction.
*
* Side effects:
* None.
@@ -978,7 +970,7 @@ static int
ConsoleGetHandleProc(
ClientData instanceData, /* The console state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
- ClientData *handlePtr) /* Where to store the handle. */
+ ClientData *handlePtr) /* Where to store the handle. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
@@ -991,27 +983,25 @@ ConsoleGetHandleProc(
*
* WaitForRead --
*
- * Wait until some data is available, the console is at
- * EOF or the reader thread is blocked waiting for data (if the
- * channel is in non-blocking mode).
+ * Wait until some data is available, the console is at EOF or the reader
+ * thread is blocked waiting for data (if the channel is in non-blocking
+ * mode).
*
* Results:
- * Returns 1 if console is readable. Returns 0 if there is no data
- * on the console, but there is buffered data. Returns -1 if an
- * error occurred. If an error occurred, the threads may not
- * be synchronized.
+ * Returns 1 if console is readable. Returns 0 if there is no data on the
+ * console, but there is buffered data. Returns -1 if an error occurred.
+ * If an error occurred, the threads may not be synchronized.
*
* Side effects:
- * Updates the shared state flags. If no error occurred,
- * the reader thread is blocked waiting for a signal from the
- * main thread.
+ * Updates the shared state flags. If no error occurred, the reader
+ * thread is blocked waiting for a signal from the main thread.
*
*----------------------------------------------------------------------
*/
static int
WaitForRead(
- ConsoleInfo *infoPtr, /* Console state. */
+ ConsoleInfo *infoPtr, /* Console state. */
int blocking) /* Indicates whether call should be
* blocking or not. */
{
@@ -1030,13 +1020,14 @@ WaitForRead(
* The reader thread is blocked waiting for data and the channel
* is in non-blocking mode.
*/
+
errno = EAGAIN;
return -1;
}
/*
- * At this point, the two threads are synchronized, so it is safe
- * to access shared state.
+ * At this point, the two threads are synchronized, so it is safe to
+ * access shared state.
*/
/*
@@ -1048,7 +1039,7 @@ WaitForRead(
}
if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) {
- /*
+ /*
* Check to see if the peek failed because of EOF.
*/
@@ -1071,18 +1062,16 @@ WaitForRead(
}
/*
- * If there is data in the buffer, the console must be
- * readable (since it is a line-oriented device).
+ * If there is data in the buffer, the console must be readable (since
+ * it is a line-oriented device).
*/
if (infoPtr->readFlags & CONSOLE_BUFFERED) {
return 1;
}
-
/*
- * There wasn't any data available, so reset the thread and
- * try again.
+ * There wasn't any data available, so reset the thread and try again.
*/
ResetEvent(infoPtr->readable);
@@ -1095,16 +1084,16 @@ WaitForRead(
*
* ConsoleReaderThread --
*
- * This function runs in a separate thread and waits for input
- * to become available on a console.
+ * This function runs in a separate thread and waits for input to become
+ * available on a console.
*
* Results:
* None.
*
* Side effects:
- * Signals the main thread when input become available. May
- * cause the main thread to wake up by posting a message. May
- * one line from the console for each wait operation.
+ * Signals the main thread when input become available. May cause the
+ * main thread to wake up by posting a message. May one line from the
+ * console for each wait operation.
*
*----------------------------------------------------------------------
*/
@@ -1130,8 +1119,8 @@ ConsoleReaderThread(LPVOID arg)
if (waitResult != (WAIT_OBJECT_0 + 1)) {
/*
- * The start event was not signaled. It must be the stop event
- * or an error, so exit this thread.
+ * The start event was not signaled. It must be the stop event or
+ * an error, so exit this thread.
*/
break;
@@ -1140,9 +1129,10 @@ ConsoleReaderThread(LPVOID arg)
count = 0;
/*
- * Look for data on the console, but first ignore any events
- * that are not KEY_EVENTs
+ * Look for data on the console, but first ignore any events that are
+ * not KEY_EVENTs.
*/
+
if (ReadConsoleA(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
(LPDWORD) &infoPtr->bytesRead, NULL) != FALSE) {
/*
@@ -1160,21 +1150,24 @@ ConsoleReaderThread(LPVOID arg)
}
/*
- * Signal the main thread by signalling the readable event and
- * then waking up the notifier thread.
+ * Signal the main thread by signalling the readable event and then
+ * waking up the notifier thread.
*/
SetEvent(infoPtr->readable);
/*
- * Alert the foreground thread. Note that we need to treat this like
- * a critical section so the foreground thread does not terminate
- * this thread while we are holding a mutex in the notifier code.
+ * Alert the foreground thread. Note that we need to treat this like a
+ * critical section so the foreground thread does not terminate this
+ * thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&consoleMutex);
if (infoPtr->threadId != NULL) {
- /* TIP #218. When in flight ignore the event, no one will receive it anyway */
+ /*
+ * TIP #218. When in flight ignore the event, no one will receive
+ * it anyway.
+ */
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&consoleMutex);
@@ -1188,15 +1181,16 @@ ConsoleReaderThread(LPVOID arg)
*
* ConsoleWriterThread --
*
- * This function runs in a separate thread and writes data
- * onto a console.
+ * This function runs in a separate thread and writes data onto a
+ * console.
*
* Results:
* Always returns 0.
*
* Side effects:
- * Signals the main thread when an output operation is completed.
- * May cause the main thread to wake up by posting a message.
+
+ * Signals the main thread when an output operation is completed. May
+ * cause the main thread to wake up by posting a message.
*
*----------------------------------------------------------------------
*/
@@ -1224,8 +1218,8 @@ ConsoleWriterThread(LPVOID arg)
if (waitResult != (WAIT_OBJECT_0 + 1)) {
/*
- * The start event was not signaled. It must be the stop event
- * or an error, so exit this thread.
+ * The start event was not signaled. It must be the stop event or
+ * an error, so exit this thread.
*/
break;
@@ -1249,21 +1243,24 @@ ConsoleWriterThread(LPVOID arg)
}
/*
- * Signal the main thread by signalling the writable event and
- * then waking up the notifier thread.
+ * Signal the main thread by signalling the writable event and then
+ * waking up the notifier thread.
*/
SetEvent(infoPtr->writable);
/*
- * Alert the foreground thread. Note that we need to treat this like
- * a critical section so the foreground thread does not terminate
- * this thread while we are holding a mutex in the notifier code.
+ * Alert the foreground thread. Note that we need to treat this like a
+ * critical section so the foreground thread does not terminate this
+ * thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&consoleMutex);
if (infoPtr->threadId != NULL) {
- /* TIP #218. When in flight ignore the event, no one will receive it anyway */
+ /*
+ * TIP #218. When in flight ignore the event, no one will receive
+ * it anyway.
+ */
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&consoleMutex);
@@ -1280,8 +1277,8 @@ ConsoleWriterThread(LPVOID arg)
* TclWinOpenConsoleChannel --
*
* Constructs a Console channel for the specified standard OS handle.
- * This is a helper function to break up the construction of
- * channels into File, Console, or Serial.
+ * This is a helper function to break up the construction of channels
+ * into File, Console, or Serial.
*
* Results:
* Returns the new channel, or NULL.
@@ -1320,23 +1317,23 @@ TclWinOpenConsoleChannel(handle, channelName, permissions)
infoPtr->threadId = Tcl_GetCurrentThread();
/*
- * Use the pointer for the name of the result channel.
- * This keeps the channel names unique, since some may share
- * handles (stdin/stdout/stderr for instance).
+ * Use the pointer for the name of the result channel. This keeps the
+ * channel names unique, since some may share handles (stdin/stdout/stderr
+ * for instance).
*/
wsprintfA(channelName, "file%lx", (int) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
- (ClientData) infoPtr, permissions);
+ (ClientData) infoPtr, permissions);
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
- * input notifications and the buffer is set for line buffering.
- * IOW, we only want to catch when complete lines are ready for
- * reading.
+ * input notifications and the buffer is set for line buffering. IOW,
+ * we only want to catch when complete lines are ready for reading.
*/
+
GetConsoleMode(infoPtr->handle, &modes);
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
@@ -1346,7 +1343,7 @@ TclWinOpenConsoleChannel(handle, channelName, permissions)
infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread,
- infoPtr, 0, &id);
+ infoPtr, 0, &id);
SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
}
@@ -1355,13 +1352,13 @@ TclWinOpenConsoleChannel(handle, channelName, permissions)
infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread,
- infoPtr, 0, &id);
+ infoPtr, 0, &id);
SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
}
/*
- * Files have default translation of AUTO and ^Z eof char, which
- * means that a ^Z will be accepted as EOF when reading.
+ * Files have default translation of AUTO and ^Z eof char, which means
+ * that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
@@ -1394,27 +1391,36 @@ ConsoleThreadActionProc (instanceData, action)
{
ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
- /* We do not access firstConsolePtr in the thread structures. This is
- * not for all serials managed by the thread, but only those we are
- * watching. Removal of the filevent handlers before transfer thus
- * takes care of this structure.
+ /* We do not access firstConsolePtr in the thread structures. This is not
+ * for all serials managed by the thread, but only those we are watching.
+ * Removal of the filevent handlers before transfer thus takes care of
+ * this structure.
*/
Tcl_MutexLock(&consoleMutex);
if (action == TCL_CHANNEL_THREAD_INSERT) {
- /* We can't copy the thread information from the channel when
- * the channel is created. At this time the channel back
- * pointer has not been set yet. However in that case the
- * threadId has already been set by TclpCreateCommandChannel
- * itself, so the structure is still good.
+ /*
+ * We can't copy the thread information from the channel when the
+ * channel is created. At this time the channel back pointer has not
+ * been set yet. However in that case the threadId has already been
+ * set by TclpCreateCommandChannel itself, so the structure is still
+ * good.
*/
- ConsoleInit ();
- if (infoPtr->channel != NULL) {
- infoPtr->threadId = Tcl_GetChannelThread (infoPtr->channel);
+ ConsoleInit();
+ if (infoPtr->channel != NULL) {
+ infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&consoleMutex);
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 023a037..57a7d62 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -1,16 +1,15 @@
/*
* tclWinDde.c --
*
- * This file provides procedures that implement the "send"
- * command, allowing commands to be passed from interpreter
- * to interpreter.
+ * This file provides functions that implement the "send" command,
+ * allowing commands to be passed from interpreter to interpreter.
*
* 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: tclWinDde.c,v 1.26 2004/11/30 18:40:33 kennykb Exp $
+ * RCS: @(#) $Id: tclWinDde.c,v 1.27 2005/07/24 22:56:47 dkf Exp $
*/
#include "tclInt.h"
@@ -19,11 +18,10 @@
#include <tchar.h>
/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Dde_Init declaration is in the source file itself, which is only
- * accessed when we are building a library. DO NOT MOVE BEFORE ANY
- * #include LINES. ONLY USE EXTERN TO INDICATE EXPORTED FUNCTIONS FROM
- * NOW ON.
+ * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init
+ * declaration is in the source file itself, which is only accessed when we
+ * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE
+ * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON.
*/
#undef TCL_STORAGE_CLASS
@@ -65,22 +63,22 @@ typedef struct DdeEnumServices {
typedef struct ThreadSpecificData {
Conversation *currentConversations;
- /* A list of conversations currently
- * being processed. */
+ /* A list of conversations currently being
+ * processed. */
RegisteredInterp *interpListPtr;
- /* List of all interpreters registered
- * in the current process. */
+ /* List of all interpreters registered in the
+ * current process. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
- * The following variables cannot be placed in thread-local storage.
- * The Mutex ddeMutex guards access to the ddeInstance.
+ * The following variables cannot be placed in thread-local storage. The Mutex
+ * ddeMutex guards access to the ddeInstance.
*/
static HSZ ddeServiceGlobal = 0;
-static DWORD ddeInstance; /* The application instance handle given
- * to us by DdeInitialize. */
+static DWORD ddeInstance; /* The application instance handle given to us
+ * by DdeInitialize. */
static int ddeIsServer = 0;
#define TCL_DDE_VERSION "1.3.1"
@@ -91,7 +89,7 @@ static int ddeIsServer = 0;
TCL_DECLARE_MUTEX(ddeMutex)
/*
- * Forward declarations for procedures defined later in this file.
+ * Forward declarations for functions defined later in this file.
*/
static LRESULT CALLBACK DdeClientWindowProc _ANSI_ARGS_((
@@ -102,7 +100,7 @@ static int DdeCreateClient _ANSI_ARGS_((
static BOOL CALLBACK DdeEnumWindowsCallback _ANSI_ARGS_((
HWND hwndTarget, LPARAM lParam));
static void DdeExitProc _ANSI_ARGS_((ClientData clientData));
-static int DdeGetServicesList _ANSI_ARGS_((Tcl_Interp *interp,
+static int DdeGetServicesList _ANSI_ARGS_((Tcl_Interp *interp,
char *serviceName, char *topicName));
static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType,
UINT uFmt, HCONV hConv, HSZ ddeTopic,
@@ -129,7 +127,7 @@ EXTERN int Dde_SafeInit _ANSI_ARGS_((Tcl_Interp *interp));
*
* Dde_Init --
*
- * This procedure initializes the dde command.
+ * This function initializes the dde command.
*
* Results:
* A standard Tcl result.
@@ -161,7 +159,7 @@ Dde_Init(interp)
*
* Dde_SafeInit --
*
- * This procedure initializes the dde command within a safe interp
+ * This function initializes the dde command within a safe interp
*
* Results:
* A standard Tcl result.
@@ -206,9 +204,9 @@ Initialize(void)
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * See if the application is already registered; if so, remove its
- * current name from the registry. The deletion of the command
- * will take care of disposing of this entry.
+ * See if the application is already registered; if so, remove its current
+ * name from the registry. The deletion of the command will take care of
+ * disposing of this entry.
*/
if (tsdPtr->interpListPtr != NULL) {
@@ -216,8 +214,8 @@ Initialize(void)
}
/*
- * Make sure that the DDE server is there. This is done only once,
- * add an exit handler tear it down.
+ * Make sure that the DDE server is there. This is done only once, add an
+ * exit handler tear it down.
*/
if (ddeInstance == 0) {
@@ -251,22 +249,22 @@ Initialize(void)
*
* DdeSetServerName --
*
- * This procedure is called to associate an ASCII name with a Dde
- * server. If the interpreter has already been named, the
- * name replaces the old one.
+ * This function is called to associate an ASCII name with a Dde server.
+ * If the interpreter has already been named, the name replaces the old
+ * one.
*
* Results:
- * The return value is the name actually given to the interp.
- * This will normally be the same as name, but if name was already
- * in use for a Dde Server then a name of the form "name #2" will
- * be chosen, with a high enough number to make the name unique.
+ * The return value is the name actually given to the interp. This will
+ * normally be the same as name, but if name was already in use for a Dde
+ * Server then a name of the form "name #2" will be chosen, with a high
+ * enough number to make the name unique.
*
* Side effects:
- * Registration info is saved, thereby allowing the "send" command
- * to be used later to invoke commands in the application. In
- * addition, the "send" command is created in the application's
- * interpreter. The registration will be removed automatically
- * if the interpreter is deleted or the "send" command is removed.
+ * Registration info is saved, thereby allowing the "send" command to be
+ * used later to invoke commands in the application. In addition, the
+ * "send" command is created in the application's interpreter. The
+ * registration will be removed automatically if the interpreter is
+ * deleted or the "send" command is removed.
*
*----------------------------------------------------------------------
*/
@@ -275,7 +273,7 @@ static char *
DdeSetServerName(interp, name, exactName, handlerPtr)
Tcl_Interp *interp;
char *name; /* The name that will be used to refer to the
- * interpreter in later "send" commands. Must
+ * interpreter in later "send" commands. Must
* be globally unique. */
int exactName; /* Should we make a unique name? 0 = unique */
Tcl_Obj *handlerPtr; /* Name of the optional proc/command to handle
@@ -290,9 +288,9 @@ DdeSetServerName(interp, name, exactName, handlerPtr)
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * See if the application is already registered; if so, remove its
- * current name from the registry. The deletion of the command
- * will take care of disposing of this entry.
+ * See if the application is already registered; if so, remove its current
+ * name from the registry. The deletion of the command will take care of
+ * disposing of this entry.
*/
for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
@@ -307,8 +305,8 @@ DdeSetServerName(interp, name, exactName, handlerPtr)
break;
} else {
/*
- * the name was NULL, so the caller is asking for
- * the name of the current interp.
+ * The name was NULL, so the caller is asking for the name of
+ * the current interp.
*/
return riPtr->name;
@@ -318,18 +316,18 @@ DdeSetServerName(interp, name, exactName, handlerPtr)
if (name == NULL) {
/*
- * the name was NULL, so the caller is asking for
- * the name of the current interp, but it doesn't
- * have a name.
+ * The name was NULL, so the caller is asking for the name of the
+ * current interp, but it doesn't have a name.
*/
return "";
}
/*
- * Get the list of currently registered Tcl interpreters by calling
- * the internal implementation of the 'dde services' command.
+ * Get the list of currently registered Tcl interpreters by calling the
+ * internal implementation of the 'dde services' command.
*/
+
Tcl_DStringInit(&dString);
actualName = name;
@@ -348,10 +346,9 @@ DdeSetServerName(interp, name, exactName, handlerPtr)
}
/*
- * Pick a name to use for the application. Use "name" if it's not
- * already in use. Otherwise add a suffix such as " #2", trying
- * larger and larger numbers until we eventually find one that is
- * unique.
+ * Pick a name to use for the application. Use "name" if it's not
+ * already in use. Otherwise add a suffix such as " #2", trying larger
+ * and larger numbers until we eventually find one that is unique.
*/
offset = lastSuffix = 0;
@@ -370,7 +367,10 @@ DdeSetServerName(interp, name, exactName, handlerPtr)
sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
}
- /* see if the name is already in use, if so increment suffix */
+ /*
+ * See if the name is already in use, if so increment suffix.
+ */
+
for (n = 0; n < srvCount; ++n) {
Tcl_Obj* namePtr;
@@ -410,8 +410,9 @@ DdeSetServerName(interp, name, exactName, handlerPtr)
Tcl_DStringFree(&dString);
/*
- * re-initialize with the new name
+ * Re-initialize with the new name.
*/
+
Initialize();
return riPtr->name;
@@ -454,7 +455,7 @@ DdeGetRegistrationPtr(interp)
*
* DeleteProc
*
- * This procedure is called when the command "dde" is destroyed.
+ * This function is called when the command "dde" is destroyed.
*
* Results:
* none
@@ -467,8 +468,8 @@ DdeGetRegistrationPtr(interp)
static void
DeleteProc(clientData)
- ClientData clientData; /* The interp we are deleting passed
- * as ClientData. */
+ ClientData clientData; /* The interp we are deleting passed as
+ * ClientData. */
{
RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
RegisteredInterp *searchPtr, *prevPtr;
@@ -501,21 +502,20 @@ DeleteProc(clientData)
*
* ExecuteRemoteObject --
*
- * Takes the package delivered by DDE and executes it in the
- * server's interpreter.
+ * Takes the package delivered by DDE and executes it in the server's
+ * interpreter.
*
* Results:
- * A list Tcl_Obj * that describes what happened. The first
- * element is the numerical return code (TCL_ERROR, etc.). The
- * second element is the result of the script. If the return
- * result was TCL_ERROR, then the third element will be the value
- * of the global "errorCode", and the fourth will be the value of
- * the global "errorInfo". The return result will have a
- * refCount of 0.
+ * A list Tcl_Obj * that describes what happened. The first element is
+ * the numerical return code (TCL_ERROR, etc.). The second element is the
+ * result of the script. If the return result was TCL_ERROR, then the
+ * third element will be the value of the global "errorCode", and the
+ * fourth will be the value of the global "errorInfo". The return result
+ * will have a refCount of 0.
*
* Side effects:
- * A Tcl script is run, which can cause all kinds of other things
- * to happen.
+ * A Tcl script is run, which can cause all kinds of other things to
+ * happen.
*
*----------------------------------------------------------------------
*/
@@ -536,7 +536,10 @@ ExecuteRemoteObject(riPtr, ddeObjectPtr)
}
if (riPtr->handlerPtr != NULL) {
- /* add the dde request data to the handler proc list */
+ /*
+ * Add the dde request data to the handler proc list.
+ */
+
Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);
result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr, ddeObjectPtr);
@@ -576,16 +579,16 @@ ExecuteRemoteObject(riPtr, ddeObjectPtr)
*
* DdeServerProc --
*
- * Handles all transactions for this server. Can handle execute,
- * request, and connect protocols. Dde will call this routine
- * when a client attempts to run a dde command using this server.
+ * Handles all transactions for this server. Can handle execute, request,
+ * and connect protocols. Dde will call this routine when a client
+ * attempts to run a dde command using this server.
*
* Results:
* A DDE Handle with the result of the dde command.
*
* Side effects:
- * Depending on which command is executed, arbitrary Tcl scripts
- * can be run.
+ * Depending on which command is executed, arbitrary Tcl scripts can be
+ * run.
*
*----------------------------------------------------------------------
*/
@@ -614,10 +617,9 @@ DdeServerProc(uType, uFmt, hConv, ddeTopic, ddeItem, hData, dwData1, dwData2)
switch(uType) {
case XTYP_CONNECT:
-
/*
- * Dde is trying to initialize a conversation with us. Check
- * and make sure we have a valid topic.
+ * Dde is trying to initialize a conversation with us. Check and make
+ * sure we have a valid topic.
*/
len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
@@ -639,12 +641,10 @@ DdeServerProc(uType, uFmt, hConv, ddeTopic, ddeItem, hData, dwData1, dwData2)
return (HDDEDATA) FALSE;
case XTYP_CONNECT_CONFIRM:
-
/*
- * Dde has decided that we can connect, so it gives us a
- * conversation handle. We need to keep track of it
- * so we know which execution result to return in an
- * XTYP_REQUEST.
+ * Dde has decided that we can connect, so it gives us a conversation
+ * handle. We need to keep track of it so we know which execution
+ * result to return in an XTYP_REQUEST.
*/
len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
@@ -669,7 +669,6 @@ DdeServerProc(uType, uFmt, hConv, ddeTopic, ddeItem, hData, dwData1, dwData2)
return (HDDEDATA) TRUE;
case XTYP_DISCONNECT:
-
/*
* The client has disconnected from our server. Forget this
* conversation.
@@ -694,11 +693,10 @@ DdeServerProc(uType, uFmt, hConv, ddeTopic, ddeItem, hData, dwData1, dwData2)
return (HDDEDATA) TRUE;
case XTYP_REQUEST:
-
/*
- * This could be either a request for a value of a Tcl variable,
- * or it could be the send command requesting the results of the
- * last execute.
+ * This could be either a request for a value of a Tcl variable, or it
+ * could be the send command requesting the results of the last
+ * execute.
*/
if (uFmt != CF_TEXT) {
@@ -750,11 +748,9 @@ DdeServerProc(uType, uFmt, hConv, ddeTopic, ddeItem, hData, dwData1, dwData2)
return ddeReturn;
case XTYP_EXECUTE: {
-
/*
- * Execute this script. The results will be saved into
- * a list object which will be retreived later. See
- * ExecuteRemoteObject.
+ * Execute this script. The results will be saved into a list object
+ * which will be retreived later. See ExecuteRemoteObject.
*/
Tcl_Obj *returnPackagePtr;
@@ -801,7 +797,6 @@ DdeServerProc(uType, uFmt, hConv, ddeTopic, ddeItem, hData, dwData1, dwData2)
}
case XTYP_WILDCONNECT: {
-
/*
* Dde wants a list of services and topics that we support.
*/
@@ -870,8 +865,8 @@ DdeExitProc(clientData)
*
* MakeDdeConnection --
*
- * This procedure is a utility used to connect to a DDE server
- * when given a server name and a topic name.
+ * This function is a utility used to connect to a DDE server when given
+ * a server name and a topic name.
*
* Results:
* A standard Tcl result.
@@ -915,12 +910,11 @@ MakeDdeConnection(interp, name, ddeConvPtr)
*
* DdeGetServicesList --
*
- * This procedure obtains the list of DDE services.
+ * This function obtains the list of DDE services.
*
- * The functions between here and this procedure are all involved
- * with handling the DDE callbacks for this. They are:
- * DdeCreateClient, DdeClientWindowProc, DdeServicesOnAck, and
- * DdeEnumWindowsCallback
+ * The functions between here and this function are all involved with
+ * handling the DDE callbacks for this. They are: DdeCreateClient,
+ * DdeClientWindowProc, DdeServicesOnAck, and DdeEnumWindowsCallback
*
* Results:
* A standard Tcl result.
@@ -945,7 +939,10 @@ DdeCreateClient(es)
wc.lpszClassName = szDdeClientClassName;
wc.cbWndExtra = sizeof(struct DdeEnumServices *);
- /* register and create the callback window */
+ /*
+ * Register and create the callback window.
+ */
+
RegisterClassEx(&wc);
es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName,
WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es);
@@ -1030,11 +1027,14 @@ DdeServicesOnAck(hwnd, wParam, lParam)
}
}
- /* tell the server we are no longer interested */
+ /*
+ * Tell the server we are no longer interested.
+ */
+
PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
return 0L;
}
-
+
static BOOL CALLBACK
DdeEnumWindowsCallback(hwndTarget, lParam)
HWND hwndTarget;
@@ -1048,7 +1048,7 @@ DdeEnumWindowsCallback(hwndTarget, lParam)
&dwResult);
return TRUE;
}
-
+
static int
DdeGetServicesList(interp, serviceName, topicName)
Tcl_Interp *interp;
@@ -1083,8 +1083,8 @@ DdeGetServicesList(interp, serviceName, topicName)
*
* SetDdeError --
*
- * Sets the interp result to a cogent error message describing
- * the last DDE error.
+ * Sets the interp result to a cogent error message describing the last
+ * DDE error.
*
* Results:
* None.
@@ -1125,8 +1125,8 @@ SetDdeError(interp)
*
* Tcl_DdeObjCmd --
*
- * This procedure is invoked to process the "dde" Tcl command.
- * See the user documentation for details on what it does.
+ * This function is invoked to process the "dde" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -1196,9 +1196,10 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
"option", 0, (int *) &argIndex) != TCL_OK) {
/*
- * If it is the last argument, it might be a server
- * name instead of a bad argument.
+ * If it is the last argument, it might be a server name
+ * instead of a bad argument.
*/
+
if (i != objc-1) {
return TCL_ERROR;
}
@@ -1208,8 +1209,9 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
if (argIndex == DDE_SERVERNAME_EXACT) {
exact = 1;
} else if (argIndex == DDE_SERVERNAME_HANDLER) {
- if ((objc - i) == 1) { /* return current handler */
+ if ((objc - i) == 1) { /* return current handler */
RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp);
+
if (riPtr && riPtr->handlerPtr) {
Tcl_SetObjResult(interp, riPtr->handlerPtr);
} else {
@@ -1271,7 +1273,11 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
break;
}
}
- /* otherwise ... */
+
+ /*
+ * Otherwise ...
+ */
+
Tcl_WrongNumArgs(interp, 2, objv,
"?-binary? serviceName topicName value");
return TCL_ERROR;
@@ -1284,11 +1290,12 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
break;
case DDE_EVAL:
if (objc < 4) {
- wrongDdeEvalArgs:
+ wrongDdeEvalArgs:
Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args");
return TCL_ERROR;
} else {
int dummy;
+
firstArg = 2;
if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
&dummy) == TCL_OK) {
@@ -1382,6 +1389,7 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
}
case DDE_REQUEST: {
char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
+
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot request value of null data", -1));
@@ -1483,13 +1491,12 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
((Tcl_Obj **) objv) += (async + 3);
/*
- * See if the target interpreter is local. If so, execute
- * the command directly without going through the DDE server.
- * Don't exchange objects between interps. The target interp could
- * compile an object, producing a bytecode structure that refers to
- * other objects owned by the target interp. If the target interp
- * is then deleted, the bytecode structure would be referring to
- * deallocated objects.
+ * See if the target interpreter is local. If so, execute the command
+ * directly without going through the DDE server. Don't exchange
+ * objects between interps. The target interp could compile an object,
+ * producing a bytecode structure that refers to other objects owned
+ * by the target interp. If the target interp is then deleted, the
+ * bytecode structure would be referring to deallocated objects.
*/
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
@@ -1503,8 +1510,8 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
Tcl_Interp *sendInterp;
/*
- * This command is to a local interp. No need to go through
- * the server.
+ * This command is to a local interp. No need to go through the
+ * server.
*/
Tcl_Preserve((ClientData) riPtr);
@@ -1512,11 +1519,11 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
Tcl_Preserve((ClientData) sendInterp);
/*
- * Don't exchange objects between interps. The target interp
- * would compile an object, producing a bytecode structure that
- * refers to other objects owned by the target interp. If the
- * target interp is then deleted, the bytecode structure would
- * be referring to deallocated objects.
+ * Don't exchange objects between interps. The target interp would
+ * compile an object, producing a bytecode structure that refers
+ * to other objects owned by the target interp. If the target
+ * interp is then deleted, the bytecode structure would be
+ * referring to deallocated objects.
*/
if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
@@ -1554,9 +1561,8 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
if (interp != sendInterp) {
if (result == TCL_ERROR) {
/*
- * An error occurred, so transfer error information
- * from the destination interpreter back to our
- * interpreter.
+ * An error occurred, so transfer error information from
+ * the destination interpreter back to our interpreter.
*/
Tcl_ResetResult(interp);
@@ -1579,12 +1585,12 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
Tcl_Release((ClientData) sendInterp);
} else {
/*
- * This is a non-local request. Send the script to the server
- * and poll it for a result.
+ * This is a non-local request. Send the script to the server and
+ * poll it for a result.
*/
if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
- invalidServerResponse:
+ invalidServerResponse:
Tcl_SetObjResult(interp,
Tcl_NewStringObj("invalid data returned from server",
-1));
@@ -1625,12 +1631,12 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
Tcl_Obj *resultPtr;
/*
- * The return handle has a two or four element list in
- * it. The first element is the return code (TCL_OK,
- * TCL_ERROR, etc.). The second is the result of the
- * script. If the return code is TCL_ERROR, then the third
- * element is the value of the variable "errorCode", and
- * the fourth is the value of the variable "errorInfo".
+ * The return handle has a two or four element list in it. The
+ * first element is the return code (TCL_OK, TCL_ERROR, etc.).
+ * The second is the result of the script. If the return code
+ * is TCL_ERROR, then the third element is the value of the
+ * variable "errorCode", and the fourth is the value of the
+ * variable "errorInfo".
*/
resultPtr = Tcl_NewObj();
@@ -1692,11 +1698,13 @@ Tcl_DdeObjCmd(clientData, interp, objc, objv)
}
return result;
}
-
+
/*
* Local variables:
* mode: c
* indent-tabs-mode: t
* tab-width: 8
+ * c-basic-offset: 4
+ * fill-column: 78
* End:
*/
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index 0534971..95ad80a 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -1,15 +1,15 @@
/*
* tclWinFCmd.c
*
- * This file implements the Windows specific portion of file manipulation
- * subcommands of the "file" command.
+ * This file implements the Windows specific 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: tclWinFCmd.c,v 1.46 2005/06/23 19:48:51 kennykb Exp $
+ * RCS: @(#) $Id: tclWinFCmd.c,v 1.47 2005/07/24 22:56:47 dkf Exp $
*/
#include "tclWinInt.h"
@@ -19,30 +19,25 @@
* TraverseWinTree() calls the traverseProc()
*/
-#define DOTREE_PRED 1 /* pre-order directory */
-#define DOTREE_POSTD 2 /* post-order directory */
-#define DOTREE_F 3 /* regular file */
-#define DOTREE_LINK 4 /* symbolic link */
+#define DOTREE_PRED 1 /* pre-order directory */
+#define DOTREE_POSTD 2 /* post-order directory */
+#define DOTREE_F 3 /* regular file */
+#define DOTREE_LINK 4 /* symbolic link */
/*
* Callbacks for file attributes code.
*/
-static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj **attributePtrPtr));
-static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj **attributePtrPtr));
-static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj **attributePtrPtr));
-static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj *attributePtr));
-static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj *attributePtr));
+static int GetWinFileAttributes(Tcl_Interp *interp, int objIndex,
+ Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
+static int GetWinFileLongName(Tcl_Interp *interp, int objIndex,
+ Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
+static int GetWinFileShortName(Tcl_Interp *interp, int objIndex,
+ Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr));
+static int SetWinFileAttributes(Tcl_Interp *interp, int objIndex,
+ Tcl_Obj *fileName, Tcl_Obj *attributePtr);
+static int CannotSetAttribute(Tcl_Interp *interp, int objIndex,
+ Tcl_Obj *fileName, Tcl_Obj *attributePtr));
/*
* Constants and variables necessary for file attributes subcommand.
@@ -77,18 +72,17 @@ CONST TclFileAttrProcs tclpFileAttrProcs[] = {
#ifdef HAVE_NO_SEH
/*
- * Unlike Borland and Microsoft, we don't register exception handlers
- * by pushing registration records onto the runtime stack. Instead, we
- * register them by creating an EXCEPTION_REGISTRATION within the activation
- * record.
+ * Unlike Borland and Microsoft, we don't register exception handlers by
+ * pushing registration records onto the runtime stack. Instead, we register
+ * them by creating an EXCEPTION_REGISTRATION within the activation record.
*/
typedef struct EXCEPTION_REGISTRATION {
- struct EXCEPTION_REGISTRATION* link;
- EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*,
- struct _CONTEXT*, void* );
- void* ebp;
- void* esp;
+ struct EXCEPTION_REGISTRATION *link;
+ EXCEPTION_DISPOSITION (*handler)(
+ struct _EXCEPTION_RECORD *, void *, struct _CONTEXT *, void *);
+ void *ebp;
+ void *esp;
int status;
} EXCEPTION_REGISTRATION;
@@ -98,91 +92,91 @@ typedef struct EXCEPTION_REGISTRATION {
* Prototype for the TraverseWinTree callback function.
*/
-typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
+typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
/*
- * Declarations for local procedures defined in this file:
+ * Declarations for local functions defined in this file:
*/
static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
-static int ConvertFileNameFormat(Tcl_Interp *interp,
+static int ConvertFileNameFormat(Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName, int longShort,
Tcl_Obj **attributePtrPtr);
static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr);
static int DoCreateDirectory(CONST TCHAR *pathPtr);
-static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc,
+static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc,
int ignoreError, Tcl_DString *errorPtr);
-static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
+static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
Tcl_DString *errorPtr);
-static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr);
-static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
- int type, Tcl_DString *errorPtr);
-static int TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
+static int DoRenameFile(CONST TCHAR *nativeSrc,
+ CONST TCHAR *dstPtr);
+static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
+static int TraversalDelete(CONST TCHAR *srcPtr,
+ CONST TCHAR *dstPtr, int type,
+ Tcl_DString *errorPtr);
static int TraverseWinTree(TraversalProc *traverseProc,
- Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
+ Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
Tcl_DString *errorPtr);
-
/*
*---------------------------------------------------------------------------
*
* TclpObjRenameFile, DoRenameFile --
*
- * Changes the name of an existing file or directory, from src to dst.
- * If src and dst refer to the same file or directory, does nothing
- * and returns success. Otherwise if dst already exists, it will be
- * deleted and replaced by src subject to the following conditions:
+ * Changes the name of an existing file or directory, from src to dst.
+ * If src and dst refer to the same file or directory, does nothing and
+ * returns success. Otherwise if dst already exists, it will be deleted
+ * and replaced by src subject to the following conditions:
* If src is a directory, dst may be an empty directory.
* If src is a file, dst may be a file.
- * In any other situation where dst already exists, the rename will
- * fail.
+ * In any other situation where dst already exists, the rename will fail.
*
* Results:
* If the file or directory was successfully renamed, returns TCL_OK.
- * Otherwise the return value is TCL_ERROR and errno is set to
- * indicate the error. Some possible values for errno are:
+ * Otherwise the return value is TCL_ERROR and errno is set to indicate
+ * the error. Some possible values for errno are:
*
* ENAMETOOLONG: src or dst names are too long.
- * EACCES: src or dst parent directory can't be read and/or written.
+ * EACCES: src or dst parent directory can't be read and/or written.
* EEXIST: dst is a non-empty directory.
* EINVAL: src is a root directory or dst is a subdirectory of src.
* EISDIR: dst is a directory, but src is not.
- * ENOENT: src doesn't exist. src or dst is "".
- * ENOTDIR: src is a directory, but dst is not.
+ * ENOENT: src doesn't exist. src or dst is "".
+ * ENOTDIR: src is a directory, but dst is not.
* EXDEV: src and dst are on different filesystems.
*
- * EACCES: exists an open file already referring to src or dst.
- * EACCES: src or dst specify the current working directory (NT).
- * EACCES: src specifies a char device (nul:, com1:, etc.)
+ * EACCES: exists an open file already referring to src or dst.
+ * EACCES: src or dst specify the current working directory (NT).
+ * EACCES: src specifies a char device (nul:, com1:, etc.)
* EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT)
* EACCES: dst specifies a char device (nul:, com1:, etc.) (95)
- *
+ *
* Side effects:
- * The implementation supports cross-filesystem renames of files,
- * but the caller should be prepared to emulate cross-filesystem
- * renames of directories if errno is EXDEV.
+ * The implementation supports cross-filesystem renames of files, but the
+ * caller should be prepared to emulate cross-filesystem renames of
+ * directories if errno is EXDEV.
*
*---------------------------------------------------------------------------
*/
-int
+int
TclpObjRenameFile(srcPathPtr, destPathPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
{
- return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
- Tcl_FSGetNativePath(destPathPtr));
+ return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
+ Tcl_FSGetNativePath(destPathPtr));
}
static int
DoRenameFile(
CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
- * (native). */
+ * (native). */
CONST TCHAR *nativeDst) /* New pathname for file or directory
* (native). */
-{
+{
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
#endif
@@ -190,8 +184,8 @@ DoRenameFile(
int retval = -1;
/*
- * The MoveFile API acts differently under Win95/98 and NT
- * WRT NULL and "". Avoid passing these values.
+ * The MoveFile API acts differently under Win95/98 and NT WRT NULL and
+ * "". Avoid passing these values.
*/
if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
@@ -201,8 +195,8 @@ DoRenameFile(
}
/*
- * The MoveFile API would throw an exception under NT
- * if one of the arguments is a char block device.
+ * The MoveFile API would throw an exception under NT if one of the
+ * arguments is a char block device.
*/
#ifndef HAVE_NO_SEH
@@ -214,88 +208,93 @@ DoRenameFile(
#else
/*
- * Don't have SEH available, do things the hard way.
- * Note that this needs to be one block of asm, to avoid stack
- * imbalance; also, it is illegal for one asm block to contain
- * a jump to another.
+ * Don't have SEH available, do things the hard way. Note that this needs
+ * to be one block of asm, to avoid stack imbalance; also, it is illegal
+ * for one asm block to contain a jump to another.
*/
__asm__ __volatile__ (
/*
- * Pick up params before messing with the stack */
+ * Pick up params before messing with the stack.
+ */
"movl %[nativeDst], %%ebx" "\n\t"
- "movl %[nativeSrc], %%ecx" "\n\t"
+ "movl %[nativeSrc], %%ecx" "\n\t"
+
+ /*
+ * Construct an EXCEPTION_REGISTRATION to protect the call to
+ * MoveFile.
+ */
+
+ "leal %[registration], %%edx" "\n\t"
+ "movl %%fs:0, %%eax" "\n\t"
+ "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
+ "leal 1f, %%eax" "\n\t"
+ "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
+ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
+ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
+ "movl $0, 0x10(%%edx)" "\n\t" /* status */
/*
- * Construct an EXCEPTION_REGISTRATION to protect the
- * call to MoveFile
+ * Link the EXCEPTION_REGISTRATION on the chain.
*/
- "leal %[registration], %%edx" "\n\t"
- "movl %%fs:0, %%eax" "\n\t"
- "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
- "leal 1f, %%eax" "\n\t"
- "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
- "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
- "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
- "movl $0, 0x10(%%edx)" "\n\t" /* status */
-
- /* Link the EXCEPTION_REGISTRATION on the chain */
-
- "movl %%edx, %%fs:0" "\n\t"
-
- /* Call MoveFile( nativeSrc, nativeDst ) */
-
+
+ "movl %%edx, %%fs:0" "\n\t"
+
+ /*
+ * Call MoveFile(nativeSrc, nativeDst)
+ */
+
"pushl %%ebx" "\n\t"
"pushl %%ecx" "\n\t"
"movl %[moveFile], %%eax" "\n\t"
"call *%%eax" "\n\t"
-
- /*
- * Come here on normal exit. Recover the EXCEPTION_REGISTRATION
- * and put the status return from MoveFile into it.
+
+ /*
+ * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and
+ * put the status return from MoveFile into it.
*/
-
+
"movl %%fs:0, %%edx" "\n\t"
"movl %%eax, 0x10(%%edx)" "\n\t"
"jmp 2f" "\n"
-
+
/*
- * Come here on an exception. Recover the EXCEPTION_REGISTRATION
+ * Come here on an exception. Recover the EXCEPTION_REGISTRATION
*/
-
+
"1:" "\t"
- "movl %%fs:0, %%edx" "\n\t"
- "movl 0x8(%%edx), %%edx" "\n\t"
-
- /*
- * Come here however we exited. Restore context from the
+ "movl %%fs:0, %%edx" "\n\t"
+ "movl 0x8(%%edx), %%edx" "\n\t"
+
+ /*
+ * Come here however we exited. Restore context from the
* EXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
-
- "2:" "\t"
- "movl 0xc(%%edx), %%esp" "\n\t"
- "movl 0x8(%%edx), %%ebp" "\n\t"
- "movl 0x0(%%edx), %%eax" "\n\t"
- "movl %%eax, %%fs:0" "\n\t"
-
+
+ "2:" "\t"
+ "movl 0xc(%%edx), %%esp" "\n\t"
+ "movl 0x8(%%edx), %%ebp" "\n\t"
+ "movl 0x0(%%edx), %%eax" "\n\t"
+ "movl %%eax, %%fs:0" "\n\t"
+
:
/* No outputs */
- :
- [registration] "m" (registration),
- [nativeDst] "m" (nativeDst),
- [nativeSrc] "m" (nativeSrc),
- [moveFile] "r" (tclWinProcs->moveFileProc)
- :
+ :
+ [registration] "m" (registration),
+ [nativeDst] "m" (nativeDst),
+ [nativeSrc] "m" (nativeSrc),
+ [moveFile] "r" (tclWinProcs->moveFileProc)
+ :
"%eax", "%ebx", "%ecx", "%edx", "memory"
- );
+ );
if (registration.status != FALSE) {
retval = TCL_OK;
}
#endif
if (retval != -1) {
- return retval;
+ return retval;
}
TclWinConvertError(GetLastError());
@@ -303,14 +302,16 @@ DoRenameFile(
srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
if (srcAttr == 0xffffffff) {
- if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {
+ if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL,
+ NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
srcAttr = 0;
}
if (dstAttr == 0xffffffff) {
- if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) {
+ if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL,
+ NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
@@ -322,7 +323,7 @@ DoRenameFile(
return TCL_ERROR;
}
if (errno == EACCES) {
- decode:
+ decode:
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
TCHAR *nativeSrcRest, *nativeDstRest;
CONST char **srcArgv, **dstArgv;
@@ -332,12 +333,12 @@ DoRenameFile(
Tcl_DString srcString, dstString;
CONST char *src, *dst;
- size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
+ size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
nativeSrcPath, &nativeSrcRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
- size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
+ size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
nativeDstPath, &nativeDstRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
@@ -347,12 +348,14 @@ DoRenameFile(
src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
+
/*
* Check whether the destination path is actually inside the
- * source path. This is true if the prefix matches, and the next
+ * source path. This is true if the prefix matches, and the next
* character is either end-of-string or a directory separator
*/
- if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0)
+
+ if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0)
&& (dst[Tcl_DStringLength(&srcString)] == '\\'
|| dst[Tcl_DStringLength(&srcString)] == '/'
|| dst[Tcl_DStringLength(&srcString)] == '\0')) {
@@ -372,22 +375,20 @@ DoRenameFile(
if (srcArgc == 1) {
/*
- * They are trying to move a root directory. Whether
- * or not it is across filesystems, this cannot be
- * done.
+ * They are trying to move a root directory. Whether or not it
+ * is across filesystems, this cannot be done.
*/
Tcl_SetErrno(EINVAL);
} else if ((srcArgc > 0) && (dstArgc > 0) &&
(strcmp(srcArgv[0], dstArgv[0]) != 0)) {
/*
- * If src is a directory and dst filesystem != src
- * filesystem, errno should be EXDEV. It is very
- * important to get this behavior, so that the caller
- * can respond to a cross filesystem rename by
- * simulating it with copy and delete. The MoveFile
- * system call already handles the case of moving a
- * file between filesystems.
+ * If src is a directory and dst filesystem != src filesystem,
+ * errno should be EXDEV. It is very important to get this
+ * behavior, so that the caller can respond to a cross
+ * filesystem rename by simulating it with copy and delete.
+ * The MoveFile system call already handles the case of moving
+ * a file between filesystems.
*/
Tcl_SetErrno(EXDEV);
@@ -399,39 +400,40 @@ DoRenameFile(
/*
* Other types of access failure is that dst is a read-only
- * filesystem, that an open file referred to src or dest, or that
- * src or dest specified the current working directory on the
- * current filesystem. EACCES is returned for those cases.
+ * filesystem, that an open file referred to src or dest, or that src
+ * or dest specified the current working directory on the current
+ * filesystem. EACCES is returned for those cases.
*/
} else if (Tcl_GetErrno() == EEXIST) {
/*
- * Reports EEXIST any time the target already exists. If it makes
+ * Reports EEXIST any time the target already exists. If it makes
* sense, remove the old file and try renaming again.
*/
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
/*
- * Overwrite empty dst directory with src directory. The
- * following call will remove an empty directory. If it
- * fails, it's because it wasn't empty.
+ * Overwrite empty dst directory with src directory. The
+ * following call will remove an empty directory. If it fails,
+ * it's because it wasn't empty.
*/
if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
- * renaming again. If that fails, we'll put this empty
+ * renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
- if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
+ if ((*tclWinProcs->moveFileProc)(nativeSrc,
+ nativeDst) != FALSE) {
return TCL_OK;
}
/*
- * Some new error has occurred. Don't know what it
- * could be, but report this one.
+ * Some new error has occurred. Don't know what it could
+ * be, but report this one.
*/
TclWinConvertError(GetLastError());
@@ -454,18 +456,18 @@ DoRenameFile(
} else {
/*
* Overwrite existing file by:
- *
+ *
* 1. Rename existing file to temp name.
* 2. Rename old file to new name.
- * 3. If success, delete temp file. If failure,
- * put temp file back to old name.
+ * 3. If success, delete temp file. If failure, put temp file
+ * back to old name.
*/
TCHAR *nativeRest, *nativeTmp, *nativePrefix;
int result, size;
WCHAR tempBuf[MAX_PATH];
-
- size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
+
+ size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
tempBuf, &nativeRest);
if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
return TCL_ERROR;
@@ -475,9 +477,9 @@ DoRenameFile(
((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */
result = TCL_ERROR;
- nativePrefix = (tclWinProcs->useWide)
+ nativePrefix = (tclWinProcs->useWide)
? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
- if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
+ if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
nativePrefix, 0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
@@ -485,12 +487,14 @@ DoRenameFile(
* other app comes along in the meantime and creates the
* same temp file.
*/
-
+
nativeTmp = (TCHAR *) tempBuf;
(*tclWinProcs->deleteFileProc)(nativeTmp);
- if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {
- if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
- (*tclWinProcs->setFileAttributesProc)(nativeTmp,
+ if ((*tclWinProcs->moveFileProc)(nativeDst,
+ nativeTmp) != FALSE) {
+ if ((*tclWinProcs->moveFileProc)(nativeSrc,
+ nativeDst) != FALSE) {
+ (*tclWinProcs->setFileAttributesProc)(nativeTmp,
FILE_ATTRIBUTE_NORMAL);
(*tclWinProcs->deleteFileProc)(nativeTmp);
return TCL_OK;
@@ -498,11 +502,11 @@ DoRenameFile(
(*tclWinProcs->deleteFileProc)(nativeDst);
(*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
}
- }
+ }
/*
- * Can't backup dst file or move src file. Return that
- * error. Could happen if an open file refers to dst.
+ * Can't backup dst file or move src file. Return that
+ * error. Could happen if an open file refers to dst.
*/
TclWinConvertError(GetLastError());
@@ -526,19 +530,19 @@ DoRenameFile(
*
* TclpObjCopyFile, DoCopyFile --
*
- * Copy a single file (not a directory). If dst already exists and
- * is not a directory, it is removed.
+ * Copy a single file (not a directory). If dst already exists and is not
+ * a directory, it is removed.
*
* Results:
- * If the file was successfully copied, returns TCL_OK. Otherwise
- * the return value is TCL_ERROR and errno is set to indicate the
- * error. Some possible values for errno are:
+ * If the file was successfully copied, returns TCL_OK. Otherwise the
+ * return value is TCL_ERROR and errno is set to indicate the error.
+ * Some possible values for errno are:
*
- * EACCES: src or dst parent directory can't be read and/or written.
+ * EACCES: src or dst parent directory can't be read and/or written.
* EISDIR: src or dst is a directory.
- * ENOENT: src doesn't exist. src or dst is "".
+ * ENOENT: src doesn't exist. src or dst is "".
*
- * EACCES: exists an open file already referring to dst (95).
+ * EACCES: exists an open file already referring to dst (95).
* EACCES: src specifies a char device (nul:, com1:, etc.) (NT)
* ENOENT: src specifies a char device (nul:, com1:, etc.) (95)
*
@@ -548,19 +552,19 @@ DoRenameFile(
*---------------------------------------------------------------------------
*/
-int
+int
TclpObjCopyFile(srcPathPtr, destPathPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
{
return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
- Tcl_FSGetNativePath(destPathPtr));
+ Tcl_FSGetNativePath(destPathPtr));
}
static int
DoCopyFile(
- CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */
- CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */
+ CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */
+ CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */
{
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
@@ -568,8 +572,8 @@ DoCopyFile(
int retval = -1;
/*
- * The CopyFile API acts differently under Win95/98 and NT
- * WRT NULL and "". Avoid passing these values.
+ * The CopyFile API acts differently under Win95/98 and NT WRT NULL and
+ * "". Avoid passing these values.
*/
if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
@@ -577,13 +581,13 @@ DoCopyFile(
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
-
+
/*
- * The CopyFile API would throw an exception under NT if one
- * of the arguments is a char block device.
+ * The CopyFile API would throw an exception under NT if one of the
+ * arguments is a char block device.
*/
-#ifndef HAVE_NO_SEH
+#ifndef HAVE_NO_SEHq
__try {
if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
retval = TCL_OK;
@@ -592,10 +596,9 @@ DoCopyFile(
#else
/*
- * Don't have SEH available, do things the hard way.
- * Note that this needs to be one block of asm, to avoid stack
- * imbalance; also, it is illegal for one asm block to contain
- * a jump to another.
+ * Don't have SEH available, do things the hard way. Note that this needs
+ * to be one block of asm, to avoid stack imbalance; also, it is illegal
+ * for one asm block to contain a jump to another.
*/
__asm__ __volatile__ (
@@ -604,78 +607,84 @@ DoCopyFile(
* Pick up parameters before messing with the stack
*/
- "movl %[nativeDst], %%ebx" "\n\t"
- "movl %[nativeSrc], %%ecx" "\n\t"
+ "movl %[nativeDst], %%ebx" "\n\t"
+ "movl %[nativeSrc], %%ecx" "\n\t"
+
+ /*
+ * Construct an EXCEPTION_REGISTRATION to protect the call to
+ * CopyFile.
+ */
+
+ "leal %[registration], %%edx" "\n\t"
+ "movl %%fs:0, %%eax" "\n\t"
+ "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
+ "leal 1f, %%eax" "\n\t"
+ "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
+ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
+ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
+ "movl $0, 0x10(%%edx)" "\n\t" /* status */
+
+ /*
+ * Link the EXCEPTION_REGISTRATION on the chain.
+ */
+
+ "movl %%edx, %%fs:0" "\n\t"
+
/*
- * Construct an EXCEPTION_REGISTRATION to protect the
- * call to CopyFile
+ * Call CopyFile(nativeSrc, nativeDst, 0)
*/
- "leal %[registration], %%edx" "\n\t"
- "movl %%fs:0, %%eax" "\n\t"
- "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
- "leal 1f, %%eax" "\n\t"
- "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
- "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
- "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
- "movl $0, 0x10(%%edx)" "\n\t" /* status */
-
- /* Link the EXCEPTION_REGISTRATION on the chain */
-
- "movl %%edx, %%fs:0" "\n\t"
-
- /* Call CopyFile( nativeSrc, nativeDst, 0 ) */
-
+
"movl %[copyFile], %%eax" "\n\t"
- "pushl $0" "\n\t"
+ "pushl $0" "\n\t"
"pushl %%ebx" "\n\t"
"pushl %%ecx" "\n\t"
"call *%%eax" "\n\t"
-
- /*
- * Come here on normal exit. Recover the EXCEPTION_REGISTRATION
- * and put the status return from CopyFile into it.
+
+ /*
+ * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and
+ * put the status return from CopyFile into it.
*/
-
+
"movl %%fs:0, %%edx" "\n\t"
"movl %%eax, 0x10(%%edx)" "\n\t"
"jmp 2f" "\n"
-
+
/*
- * Come here on an exception. Recover the EXCEPTION_REGISTRATION
+ * Come here on an exception. Recover the EXCEPTION_REGISTRATION
*/
-
+
"1:" "\t"
- "movl %%fs:0, %%edx" "\n\t"
- "movl 0x8(%%edx), %%edx" "\n\t"
-
- /*
- * Come here however we exited. Restore context from the
+ "movl %%fs:0, %%edx" "\n\t"
+ "movl 0x8(%%edx), %%edx" "\n\t"
+
+ /*
+ * Come here however we exited. Restore context from the
* EXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
-
- "2:" "\t"
- "movl 0xc(%%edx), %%esp" "\n\t"
- "movl 0x8(%%edx), %%ebp" "\n\t"
- "movl 0x0(%%edx), %%eax" "\n\t"
- "movl %%eax, %%fs:0" "\n\t"
-
+
+ "2:" "\t"
+ "movl 0xc(%%edx), %%esp" "\n\t"
+ "movl 0x8(%%edx), %%ebp" "\n\t"
+ "movl 0x0(%%edx), %%eax" "\n\t"
+ "movl %%eax, %%fs:0" "\n\t"
+
:
/* No outputs */
- :
- [registration] "m" (registration),
- [nativeDst] "m" (nativeDst),
- [nativeSrc] "m" (nativeSrc),
- [copyFile] "r" (tclWinProcs->copyFileProc)
- :
+ :
+ [registration] "m" (registration),
+ [nativeDst] "m" (nativeDst),
+ [nativeSrc] "m" (nativeSrc),
+ [copyFile] "r" (tclWinProcs->copyFileProc)
+ :
"%eax", "%ebx", "%ecx", "%edx", "memory"
- );
+ );
if (registration.status != FALSE) {
retval = TCL_OK;
}
#endif
if (retval != -1) {
- return retval;
+ return retval;
}
TclWinConvertError(GetLastError());
@@ -696,21 +705,23 @@ DoCopyFile(
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* Source is a symbolic link -- copy it */
- if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) {
- return TCL_OK;
+ if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) {
+ return TCL_OK;
}
}
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
- (*tclWinProcs->setFileAttributesProc)(nativeDst,
+ (*tclWinProcs->setFileAttributesProc)(nativeDst,
dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
- if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
+ if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst,
+ 0) != FALSE) {
return TCL_OK;
}
+
/*
- * Still can't copy onto dst. Return that error, and
- * restore attributes of dst.
+ * Still can't copy onto dst. Return that error, and restore
+ * attributes of dst.
*/
TclWinConvertError(GetLastError());
@@ -726,27 +737,27 @@ DoCopyFile(
*
* TclpObjDeleteFile, TclpDeleteFile --
*
- * Removes a single file (not a directory).
+ * Removes a single file (not a directory).
*
* Results:
- * If the file was successfully deleted, returns TCL_OK. Otherwise
- * the return value is TCL_ERROR and errno is set to indicate the
- * error. Some possible values for errno are:
+ * If the file was successfully deleted, returns TCL_OK. Otherwise the
+ * return value is TCL_ERROR and errno is set to indicate the error.
+ * Some possible values for errno are:
*
- * EACCES: a parent directory can't be read and/or written.
+ * EACCES: a parent directory can't be read and/or written.
* EISDIR: path is a directory.
* ENOENT: path doesn't exist or is "".
*
- * EACCES: exists an open file already referring to path.
+ * EACCES: exists an open file already referring to path.
* EACCES: path is a char device (nul:, com1:, etc.)
*
* Side effects:
- * The file is deleted, even if it is read-only.
+ * The file is deleted, even if it is read-only.
*
*---------------------------------------------------------------------------
*/
-int
+int
TclpObjDeleteFile(pathPtr)
Tcl_Obj *pathPtr;
{
@@ -760,8 +771,8 @@ TclpDeleteFile(
DWORD attr;
/*
- * The DeleteFile API acts differently under Win95/98 and NT
- * WRT NULL and "". Avoid passing these values.
+ * The DeleteFile API acts differently under Win95/98 and NT WRT NULL and
+ * "". Avoid passing these values.
*/
if (nativePath == NULL || nativePath[0] == '\0') {
@@ -775,27 +786,30 @@ TclpDeleteFile(
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
- /* It is a symbolic link -- remove it */
+ /*
+ * It is a symbolic link - remove it.
+ */
if (TclWinSymLinkDelete(nativePath, 0) == 0) {
- return TCL_OK;
+ return TCL_OK;
}
}
-
- /*
+
+ /*
* If we fall through here, it is a directory.
- *
+ *
* Windows NT reports removing a directory as EACCES instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
- int res = (*tclWinProcs->setFileAttributesProc)(nativePath,
+ int res = (*tclWinProcs->setFileAttributesProc)(nativePath,
attr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
+
if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
!= FALSE)) {
return TCL_OK;
@@ -807,12 +821,12 @@ TclpDeleteFile(
}
}
} else if (Tcl_GetErrno() == ENOENT) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
- /*
- * Windows 95 reports removing a directory as ENOENT instead
- * of EISDIR.
+ /*
+ * Windows 95 reports removing a directory as ENOENT instead
+ * of EISDIR.
*/
Tcl_SetErrno(EISDIR);
@@ -835,27 +849,27 @@ TclpDeleteFile(
*
* TclpObjCreateDirectory --
*
- * Creates the specified directory. All parent directories of the
- * specified directory must already exist. The directory is
- * automatically created with permissions so that user can access
- * the new directory and create new files or subdirectories in it.
+ * Creates the specified directory. All parent directories of the
+ * specified directory must already exist. The directory is automatically
+ * created with permissions so that user can access the new directory and
+ * create new files or subdirectories in it.
*
* Results:
- * If the directory was successfully created, returns TCL_OK.
- * Otherwise the return value is TCL_ERROR and errno is set to
- * indicate the error. Some possible values for errno are:
+ * If the directory was successfully created, returns TCL_OK. Otherwise
+ * the return value is TCL_ERROR and errno is set to indicate the error.
+ * Some possible values for errno are:
*
- * EACCES: a parent directory can't be read and/or written.
+ * EACCES: a parent directory can't be read and/or written.
* EEXIST: path already exists.
* ENOENT: a parent directory doesn't exist.
*
* Side effects:
- * A directory is created.
+ * A directory is created.
*
*---------------------------------------------------------------------------
*/
-int
+int
TclpObjCreateDirectory(pathPtr)
Tcl_Obj *pathPtr;
{
@@ -871,7 +885,7 @@ DoCreateDirectory(
error = GetLastError();
TclWinConvertError(error);
return TCL_ERROR;
- }
+ }
return TCL_OK;
}
@@ -880,28 +894,26 @@ DoCreateDirectory(
*
* TclpObjCopyDirectory --
*
- * Recursively copies a directory. The target directory dst must
- * not already exist. Note that this function does not merge two
- * directory hierarchies, even if the target directory is an an
- * empty directory.
+ * Recursively copies a directory. The target directory dst must not
+ * already exist. Note that this function does not merge two directory
+ * hierarchies, even if the target directory is an an empty directory.
*
* Results:
- * If the directory was successfully copied, returns TCL_OK.
- * Otherwise the return value is TCL_ERROR, errno is set to indicate
- * the error, and the pathname of the file that caused the error
- * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile
- * for a description of possible values for errno.
+ * If the directory was successfully copied, returns TCL_OK. Otherwise
+ * the return value is TCL_ERROR, errno is set to indicate the error, and
+ * the pathname of the file that caused the error is stored in errorPtr.
+ * See TclpCreateDirectory and TclpCopyFile for a description of possible
+ * values for errno.
*
* Side effects:
- * An exact copy of the directory hierarchy src will be created
- * with the name dst. If an error occurs, the error will
- * be returned immediately, and remaining files will not be
- * processed.
+ * An exact copy of the directory hierarchy src will be created with the
+ * name dst. If an error occurs, the error will be returned immediately,
+ * and remaining files will not be processed.
*
*---------------------------------------------------------------------------
*/
-int
+int
TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
@@ -923,9 +935,9 @@ TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
- if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normSrcPtr))) {
+ if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) {
*errorPtr = srcPathPtr;
- } else if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normDestPtr))) {
+ } else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) {
*errorPtr = destPathPtr;
} else {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
@@ -939,33 +951,33 @@ TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
/*
*----------------------------------------------------------------------
*
- * TclpObjRemoveDirectory, DoRemoveDirectory --
+ * TclpObjRemoveDirectory, DoRemoveDirectory --
*
* Removes directory (and its contents, if the recursive flag is set).
*
* Results:
- * If the directory was successfully removed, returns TCL_OK.
- * Otherwise the return value is TCL_ERROR, errno is set to indicate
- * the error, and the pathname of the file that caused the error
- * is stored in errorPtr. Some possible values for errno are:
+ * If the directory was successfully removed, returns TCL_OK. Otherwise
+ * the return value is TCL_ERROR, errno is set to indicate the error, and
+ * the pathname of the file that caused the error is stored in errorPtr.
+ * Some possible values for errno are:
*
- * EACCES: path directory can't be read and/or written.
+ * EACCES: path directory can't be read and/or written.
* EEXIST: path is a non-empty directory.
* EINVAL: path is root directory or current directory.
* ENOENT: path doesn't exist or is "".
- * ENOTDIR: path is not a directory.
+ * ENOTDIR: path is not a directory.
*
* EACCES: path is a char device (nul:, com1:, etc.) (95)
* EINVAL: path is a char device (nul:, com1:, etc.) (NT)
*
* Side effects:
- * Directory removed. If an error occurs, the error will be returned
+ * Directory removed. If an error occurs, the error will be returned
* immediately, and remaining files will not be deleted.
*
*----------------------------------------------------------------------
*/
-int
+int
TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
Tcl_Obj *pathPtr;
int recursive;
@@ -974,21 +986,23 @@ TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
Tcl_DString ds;
Tcl_Obj *normPtr = NULL;
int ret;
+
if (recursive) {
- /*
+ /*
* In the recursive case, the string rep is used to construct a
- * Tcl_DString which may be used extensively, so we can't
- * optimize this case easily.
+ * Tcl_DString which may be used extensively, so we can't optimize
+ * this case easily.
*/
+
Tcl_DString native;
normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
- ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr),
- 0, &ds);
+ ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds);
}
+
if (ret != TCL_OK) {
int len = Tcl_DStringLength(&ds);
if (len > 0) {
@@ -1002,6 +1016,7 @@ TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
}
Tcl_DStringFree(&ds);
}
+
return ret;
}
@@ -1009,17 +1024,17 @@ static int
DoRemoveJustDirectory(
CONST TCHAR *nativePath, /* Pathname of directory to be removed
* (native). */
- int ignoreError, /* If non-zero, don't initialize the
- * errorPtr under some circumstances
- * on return. */
- Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
+ int ignoreError, /* If non-zero, don't initialize the errorPtr
+ * under some circumstances on return. */
+ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
+ * filled with UTF-8 name of file causing
+ * error. */
{
DWORD attr;
+
/*
- * The RemoveDirectory API acts differently under Win95/98 and NT
- * WRT NULL and "". Avoid passing these values.
+ * The RemoveDirectory API acts differently under Win95/98 and NT WRT NULL
+ * and "". Avoid passing these values.
*/
if (nativePath == NULL || nativePath[0] == '\0') {
@@ -1030,57 +1045,65 @@ DoRemoveJustDirectory(
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
- /* It is a symbolic link -- remove it */
+ /*
+ * It is a symbolic link - remove it.
+ */
if (TclWinSymLinkDelete(nativePath, 0) == 0) {
return TCL_OK;
}
} else {
- /* Ordinary directory */
+ /*
+ * Ordinary directory.
+ */
+
if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
}
}
-
+
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
- /*
- * Windows 95 reports calling RemoveDirectory on a file as an
+ /*
+ * Windows 95 reports calling RemoveDirectory on a file as an
* EACCES, not an ENOTDIR.
*/
-
+
Tcl_SetErrno(ENOTDIR);
goto end;
}
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
- /* It is a symbolic link -- remove it */
+ /*
+ * It is a symbolic link - remove it.
+ */
+
if (TclWinSymLinkDelete(nativePath, 1) != 0) {
goto end;
}
}
-
+
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
- if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
+ if ((*tclWinProcs->setFileAttributesProc)(nativePath,
+ attr) == FALSE) {
goto end;
}
if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
- (*tclWinProcs->setFileAttributesProc)(nativePath,
+ (*tclWinProcs->setFileAttributesProc)(nativePath,
attr | FILE_ATTRIBUTE_READONLY);
}
- /*
- * Windows 95 and Win32s report removing a non-empty directory
- * as EACCES, not EEXIST. If the directory is not empty,
- * change errno so caller knows what's going on.
-
+ /*
+ * Windows 95 and Win32s report removing a non-empty directory as
+ * EACCES, not EEXIST. If the directory is not empty, change errno
+ * so caller knows what's going on.
*/
if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
@@ -1121,24 +1144,25 @@ DoRemoveJustDirectory(
}
}
}
+
if (Tcl_GetErrno() == ENOTEMPTY) {
- /*
- * The caller depends on EEXIST to signify that the directory is
- * not empty, not ENOTEMPTY.
+ /*
+ * The caller depends on EEXIST to signify that the directory is not
+ * empty, not ENOTEMPTY.
*/
Tcl_SetErrno(EEXIST);
}
+
if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
- /*
- * If we're being recursive, this error may actually
- * be ok, so we don't want to initialise the errorPtr
- * yet.
+ /*
+ * If we're being recursive, this error may actually be ok, so we
+ * don't want to initialise the errorPtr yet.
*/
return TCL_ERROR;
}
- end:
+ end:
if (errorPtr != NULL) {
Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
}
@@ -1150,21 +1174,22 @@ static int
DoRemoveDirectory(
Tcl_DString *pathPtr, /* Pathname of directory to be removed
* (native). */
- int recursive, /* If non-zero, removes directories that
- * are nonempty. Otherwise, will only remove
- * empty directories. */
- Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
+ int recursive, /* If non-zero, removes directories that are
+ * nonempty. Otherwise, will only remove empty
+ * directories. */
+ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
+ * filled with UTF-8 name of file causing
+ * error. */
{
- int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive,
- errorPtr);
-
+ int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive,
+ errorPtr);
+
if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
/*
* The directory is nonempty, but the recursive flag has been
* specified, so we recursively remove all the files in the directory.
*/
+
return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
} else {
return res;
@@ -1176,24 +1201,24 @@ DoRemoveDirectory(
*
* TraverseWinTree --
*
- * Traverse directory tree specified by sourcePtr, calling the function
- * traverseProc for each file and directory encountered. If destPtr
- * is non-null, each of name in the sourcePtr directory is appended to
- * the directory specified by destPtr and passed as the second argument
- * to traverseProc() .
+ * Traverse directory tree specified by sourcePtr, calling the function
+ * traverseProc for each file and directory encountered. If destPtr is
+ * non-null, each of name in the sourcePtr directory is appended to the
+ * directory specified by destPtr and passed as the second argument to
+ * traverseProc().
*
* Results:
- * Standard Tcl result.
+ * Standard Tcl result.
*
* Side effects:
- * None caused by TraverseWinTree, however the user specified
- * traverseProc() may change state. If an error occurs, the error will
- * be returned immediately, and remaining files will not be processed.
+ * None caused by TraverseWinTree, however the user specified
+ * traverseProc() may change state. If an error occurs, the error will be
+ * returned immediately, and remaining files will not be processed.
*
*---------------------------------------------------------------------------
*/
-static int
+static int
TraverseWinTree(
TraversalProc *traverseProc,/* Function to call for every file and
* directory in source hierarchy. */
@@ -1202,9 +1227,9 @@ TraverseWinTree(
Tcl_DString *targetPtr, /* Pathname of directory to traverse in
* parallel with source directory (native),
* may be NULL. */
- Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
+ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
+ * filled with UTF-8 name of file causing
+ * error. */
{
DWORD sourceAttr;
TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
@@ -1217,25 +1242,25 @@ TraverseWinTree(
oldTargetLen = 0; /* lint. */
nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
- nativeTarget = (TCHAR *) (targetPtr == NULL
- ? NULL : Tcl_DStringValue(targetPtr));
-
+ nativeTarget = (TCHAR *)
+ (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
+
oldSourceLen = Tcl_DStringLength(sourcePtr);
sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
if (sourceAttr == 0xffffffff) {
nativeErrfile = nativeSource;
goto end;
}
-
+
if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* Process the symbolic link
*/
- return (*traverseProc)(nativeSource, nativeTarget,
- DOTREE_LINK, errorPtr);
+ return (*traverseProc)(nativeSource, nativeTarget, DOTREE_LINK,
+ errorPtr);
}
-
+
if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* Process the regular file
@@ -1250,11 +1275,12 @@ TraverseWinTree(
} else {
Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
}
+
nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
if (handle == INVALID_HANDLE_VALUE) {
- /*
- * Can't read directory
+ /*
+ * Can't read directory.
*/
TclWinConvertError(GetLastError());
@@ -1264,7 +1290,8 @@ TraverseWinTree(
nativeSource[oldSourceLen + 1] = '\0';
Tcl_DStringSetLength(sourcePtr, oldSourceLen);
- result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr);
+ result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED,
+ errorPtr);
if (result != TCL_OK) {
FindClose(handle);
return result;
@@ -1295,7 +1322,7 @@ TraverseWinTree(
}
found = 1;
- for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
+ for (; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
TCHAR *nativeName;
int len;
@@ -1315,7 +1342,7 @@ TraverseWinTree(
nativeName = (TCHAR *) data.w.cFileName;
len = wcslen(data.w.cFileName) * sizeof(WCHAR);
} else {
- if ((strcmp(data.a.cFileName, ".") == 0)
+ if ((strcmp(data.a.cFileName, ".") == 0)
|| (strcmp(data.a.cFileName, "..") == 0)) {
continue;
}
@@ -1323,8 +1350,8 @@ TraverseWinTree(
len = strlen(data.a.cFileName);
}
- /*
- * Append name after slash, and recurse on the file.
+ /*
+ * Append name after slash, and recurse on the file.
*/
Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
@@ -1333,7 +1360,7 @@ TraverseWinTree(
Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
}
- result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
+ result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
errorPtr);
if (result != TCL_OK) {
break;
@@ -1351,7 +1378,7 @@ TraverseWinTree(
FindClose(handle);
/*
- * Strip off the trailing slash we added
+ * Strip off the trailing slash we added.
*/
Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
@@ -1366,11 +1393,12 @@ TraverseWinTree(
* files in that directory.
*/
- result = (*traverseProc)(Tcl_DStringValue(sourcePtr),
- (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
- DOTREE_POSTD, errorPtr);
+ result = (*traverseProc)(Tcl_DStringValue(sourcePtr),
+ (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
+ DOTREE_POSTD, errorPtr);
}
- end:
+
+ end:
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
@@ -1387,19 +1415,19 @@ TraverseWinTree(
*
* TraversalCopy
*
- * Called from TraverseUnixTree in order to execute a recursive
- * copy of a directory.
+ * Called from TraverseUnixTree in order to execute a recursive copy of a
+ * directory.
*
* Results:
- * Standard Tcl result.
+ * Standard Tcl result.
*
* Side effects:
- * Depending on the value of type, src may be copied to dst.
- *
+ * Depending on the value of type, src may be copied to dst.
+ *
*----------------------------------------------------------------------
*/
-static int
+static int
TraversalCopy(
CONST TCHAR *nativeSrc, /* Source pathname to copy. */
CONST TCHAR *nativeDst, /* Destination pathname of copy. */
@@ -1408,37 +1436,34 @@ TraversalCopy(
* with UTF-8 name of file causing error. */
{
switch (type) {
- case DOTREE_F: {
- if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
- return TCL_OK;
- }
- break;
+ case DOTREE_F:
+ if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
+ return TCL_OK;
}
- case DOTREE_LINK: {
- if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
- return TCL_OK;
- }
- break;
+ break;
+ case DOTREE_LINK:
+ if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
+ return TCL_OK;
}
- case DOTREE_PRED: {
- if (DoCreateDirectory(nativeDst) == TCL_OK) {
- DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
- if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr)
- != FALSE) {
- return TCL_OK;
- }
- TclWinConvertError(GetLastError());
+ break;
+ case DOTREE_PRED:
+ if (DoCreateDirectory(nativeDst) == TCL_OK) {
+ DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
+
+ if ((*tclWinProcs->setFileAttributesProc)(nativeDst,
+ attr) != FALSE) {
+ return TCL_OK;
}
- break;
- }
- case DOTREE_POSTD: {
- return TCL_OK;
+ TclWinConvertError(GetLastError());
}
+ break;
+ case DOTREE_POSTD:
+ return TCL_OK;
}
/*
- * There shouldn't be a problem with src, because we already
- * checked it to get here.
+ * There shouldn't be a problem with src, because we already checked it to
+ * get here.
*/
if (errorPtr != NULL) {
@@ -1452,24 +1477,24 @@ TraversalCopy(
*
* TraversalDelete --
*
- * Called by procedure TraverseWinTree for every file and
- * directory that it encounters in a directory hierarchy. This
- * procedure unlinks files, and removes directories after all the
- * containing files have been processed.
+ * Called by function TraverseWinTree for every file and directory that
+ * it encounters in a directory hierarchy. This function unlinks files,
+ * and removes directories after all the containing files have been
+ * processed.
*
* Results:
- * Standard Tcl result.
+ * Standard Tcl result.
*
* Side effects:
- * Files or directory specified by src will be deleted. If an
- * error occurs, the windows error is converted to a Posix error
- * and errno is set accordingly.
+ * Files or directory specified by src will be deleted. If an error
+ * occurs, the windows error is converted to a Posix error and errno is
+ * set accordingly.
*
*----------------------------------------------------------------------
*/
static int
-TraversalDelete(
+TraversalDelete(
CONST TCHAR *nativeSrc, /* Source pathname to delete. */
CONST TCHAR *dstPtr, /* Not used. */
int type, /* Reason for call - see TraverseWinTree() */
@@ -1477,27 +1502,23 @@ TraversalDelete(
* with UTF-8 name of file causing error. */
{
switch (type) {
- case DOTREE_F: {
- if (TclpDeleteFile(nativeSrc) == TCL_OK) {
- return TCL_OK;
- }
- break;
- }
- case DOTREE_LINK: {
- if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
- return TCL_OK;
- }
- break;
+ case DOTREE_F:
+ if (TclpDeleteFile(nativeSrc) == TCL_OK) {
+ return TCL_OK;
}
- case DOTREE_PRED: {
+ break;
+ case DOTREE_LINK:
+ if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
return TCL_OK;
}
- case DOTREE_POSTD: {
- if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
- return TCL_OK;
- }
- break;
+ break;
+ case DOTREE_PRED:
+ return TCL_OK;
+ case DOTREE_POSTD:
+ if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
+ return TCL_OK;
}
+ break;
}
if (errorPtr != NULL) {
@@ -1514,11 +1535,11 @@ TraversalDelete(
* Sets the object result with the appropriate error.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * The interp's object result is set with an error message
- * based on the objIndex, fileName and errno.
+ * The interp's object result is set with an error message based on the
+ * objIndex, fileName and errno.
*
*----------------------------------------------------------------------
*/
@@ -1526,11 +1547,11 @@ TraversalDelete(
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
- Tcl_Obj *fileName) /* The name of the file which caused the
+ Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName),
+ Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName),
"\": ", Tcl_PosixError(interp), (char *) NULL);
}
@@ -1539,16 +1560,16 @@ StatError(
*
* GetWinFileAttributes --
*
- * Returns a Tcl_Obj containing the value of a file attribute.
- * This routine gets the -hidden, -readonly or -system attribute.
+ * Returns a Tcl_Obj containing the value of a file attribute. This
+ * routine gets the -hidden, -readonly or -system attribute.
*
* Results:
- * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
- * will have ref count 0. If the return value is not TCL_OK,
- * attributePtrPtr is not touched.
+ * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
+ * have ref count 0. If the return value is not TCL_OK, attributePtrPtr
+ * is not touched.
*
* Side effects:
- * A new object is allocated if the file is valid.
+ * A new object is allocated if the file is valid.
*
*----------------------------------------------------------------------
*/
@@ -1557,13 +1578,13 @@ static int
GetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- Tcl_Obj *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
CONST TCHAR *nativeName;
int attr;
-
+
nativeName = Tcl_FSGetNativePath(fileName);
result = (*tclWinProcs->getFileAttributesProc)(nativeName);
@@ -1574,31 +1595,39 @@ GetWinFileAttributes(
attr = (int)(result & attributeArray[objIndex]);
if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
- /*
- * It is hidden. However there is a bug on some Windows
- * OSes in which root volumes (drives) formatted as NTFS
- * are declared hidden when they are not (and cannot be).
- *
+ /*
+ * It is hidden. However there is a bug on some Windows OSes in which
+ * root volumes (drives) formatted as NTFS are declared hidden when
+ * they are not (and cannot be).
+ *
* We test for, and fix that case, here.
*/
+
int len;
char *str = Tcl_GetStringFromObj(fileName,&len);
+
if (len < 4) {
if (len == 0) {
- /*
- * Not sure if this is possible, but we pass it on
- * anyway
+ /*
+ * Not sure if this is possible, but we pass it on anyway.
*/
} else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
- /* Path is pointing to the root volume */
+ /*
+ * Path is pointing to the root volume.
+ */
+
attr = 0;
- } else if ((str[1] == ':')
+ } else if ((str[1] == ':')
&& (len == 2 || (str[2] == '/' || str[2] == '\\'))) {
- /* Path is of the form 'x:' or 'x:/' or 'x:\' */
+ /*
+ * Path is of the form 'x:' or 'x:/' or 'x:\'
+ */
+
attr = 0;
}
}
}
+
*attributePtrPtr = Tcl_NewBooleanObj(attr);
return TCL_OK;
}
@@ -1608,21 +1637,20 @@ GetWinFileAttributes(
*
* ConvertFileNameFormat --
*
- * Returns a Tcl_Obj containing either the long or short version of the
+ * Returns a Tcl_Obj containing either the long or short version of the
* file name.
*
* Results:
- * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
- * will have ref count 0. If the return value is not TCL_OK,
- * attributePtrPtr is not touched.
- *
- * Warning: if you pass this function a drive name like 'c:' it
- * will actually return the current working directory on that
- * drive. To avoid this, make sure the drive name ends in a
- * slash, like this 'c:/'.
+ * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
+ * have ref count 0. If the return value is not TCL_OK, attributePtrPtr
+ * is not touched.
+ *
+ * Warning: if you pass this function a drive name like 'c:' it will
+ * actually return the current working directory on that drive. To avoid
+ * this, make sure the drive name ends in a slash, like this 'c:/'.
*
* Side effects:
- * A new object is allocated if the file is valid.
+ * A new object is allocated if the file is valid.
*
*----------------------------------------------------------------------
*/
@@ -1631,7 +1659,7 @@ static int
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- Tcl_Obj *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
@@ -1639,42 +1667,47 @@ ConvertFileNameFormat(
Tcl_Obj *splitPath;
splitPath = Tcl_FSSplitPath(fileName, &pathc);
-
+
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
Tcl_AppendResult(interp, "could not read \"",
- Tcl_GetString(fileName), "\": no such file or directory",
+ Tcl_GetString(fileName), "\": no such file or directory",
(char *) NULL);
}
goto cleanup;
}
-
+
/*
- * We will decrement this again at the end. It is safer to
- * do this in case any of the calls below retain a reference
- * to splitPath.
+ * We will decrement this again at the end. It is safer to do this in
+ * case any of the calls below retain a reference to splitPath.
*/
+
Tcl_IncrRefCount(splitPath);
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
int pathLen;
+
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
-
+
pathv = Tcl_GetStringFromObj(elt, &pathLen);
if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':'))
|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
/*
* Handle "/", "//machine/export", "c:/", "." or ".." by just
- * copying the string literally. Uppercase the drive letter,
- * just because it looks better under Windows to do so.
+ * copying the string literally. Uppercase the drive letter, just
+ * because it looks better under Windows to do so.
+ */
+
+ simple:
+ /*
+ * Here we are modifying the string representation in place.
+ *
+ * I believe this is legal, since this won't affect any file
+ * representation this thing may have.
*/
- simple:
- /* Here we are modifying the string representation in place */
- /* I believe this is legal, since this won't affect any
- * file representation this thing may have. */
pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
} else {
Tcl_Obj *tempPath;
@@ -1689,10 +1722,12 @@ ConvertFileNameFormat(
tempPath = Tcl_FSJoinPath(splitPath, i+1);
Tcl_IncrRefCount(tempPath);
- /*
- * We'd like to call Tcl_FSGetNativePath(tempPath)
- * but that is likely to lead to infinite loops
+
+ /*
+ * We'd like to call Tcl_FSGetNativePath(tempPath) but that is
+ * likely to lead to infinite loops.
*/
+
Tcl_DStringInit(&ds);
tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
@@ -1700,14 +1735,14 @@ ConvertFileNameFormat(
handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
- * FindFirstFile() doesn't like root directories. We
- * would only get a root directory here if the caller
- * specified "c:" or "c:." and the current directory on the
- * drive was the root directory
+ * FindFirstFile() doesn't like root directories. We would
+ * only get a root directory here if the caller specified "c:"
+ * or "c:." and the current directory on the drive was the
+ * root directory
*/
attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
- if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
+ if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
Tcl_DStringFree(&ds);
goto simple;
}
@@ -1725,7 +1760,7 @@ ConvertFileNameFormat(
if (longShort) {
if (data.w.cFileName[0] != '\0') {
nativeName = (TCHAR *) data.w.cFileName;
- }
+ }
} else {
if (data.w.cAlternateFileName[0] == '\0') {
nativeName = (TCHAR *) data.w.cFileName;
@@ -1736,7 +1771,7 @@ ConvertFileNameFormat(
if (longShort) {
if (data.a.cFileName[0] != '\0') {
nativeName = (TCHAR *) data.a.cFileName;
- }
+ }
} else {
if (data.a.cAlternateFileName[0] == '\0') {
nativeName = (TCHAR *) data.a.cFileName;
@@ -1745,12 +1780,12 @@ ConvertFileNameFormat(
}
/*
- * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
- * to dereference nativeName as a Unicode string. I have proven
- * to myself that purify is wrong by running the following
- * example when nativeName == data.w.cAlternateFileName and
- * noting that purify doesn't complain about the first line,
- * but does complain about the second.
+ * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
+ * to dereference nativeName as a Unicode string. I have proven to
+ * myself that purify is wrong by running the following example
+ * when nativeName == data.w.cAlternateFileName and noting that
+ * purify doesn't complain about the first line, but does complain
+ * about the second.
*
* fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
* fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
@@ -1758,14 +1793,18 @@ ConvertFileNameFormat(
Tcl_DStringInit(&dsTemp);
Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);
- /* Deal with issues of tildes being absolute */
+
+ /*
+ * Deal with issues of tildes being absolute.
+ */
+
if (Tcl_DStringValue(&dsTemp)[0] == '~') {
tempPath = Tcl_NewStringObj("./",2);
- Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp),
- Tcl_DStringLength(&dsTemp));
+ Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp),
+ Tcl_DStringLength(&dsTemp));
} else {
- tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
- Tcl_DStringLength(&dsTemp));
+ tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
+ Tcl_DStringLength(&dsTemp));
}
Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
Tcl_DStringFree(&ds);
@@ -1775,15 +1814,16 @@ ConvertFileNameFormat(
}
*attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
-
+
if (splitPath != NULL) {
- /*
- * Unfortunately, the object we will return may have its only
- * refCount as part of the list splitPath. This means if
- * we free splitPath, the object will disappear. So, we
- * have to be very careful here. Unfortunately this means
- * we must manipulate the object's refCount directly.
+ /*
+ * Unfortunately, the object we will return may have its only refCount
+ * as part of the list splitPath. This means if we free splitPath, the
+ * object will disappear. So, we have to be very careful here.
+ * Unfortunately this means we must manipulate the object's refCount
+ * directly.
*/
+
Tcl_IncrRefCount(*attributePtrPtr);
Tcl_DecrRefCount(splitPath);
--(*attributePtrPtr)->refCount;
@@ -1794,7 +1834,7 @@ ConvertFileNameFormat(
if (splitPath != NULL) {
Tcl_DecrRefCount(splitPath);
}
-
+
return TCL_ERROR;
}
@@ -1803,16 +1843,15 @@ ConvertFileNameFormat(
*
* GetWinFileLongName --
*
- * Returns a Tcl_Obj containing the long version of the file
- * name.
+ * Returns a Tcl_Obj containing the long version of the file name.
*
* Results:
- * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
- * will have ref count 0. If the return value is not TCL_OK,
- * attributePtrPtr is not touched.
+ * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
+ * have ref count 0. If the return value is not TCL_OK, attributePtrPtr
+ * is not touched.
*
* Side effects:
- * A new object is allocated if the file is valid.
+ * A new object is allocated if the file is valid.
*
*----------------------------------------------------------------------
*/
@@ -1821,10 +1860,11 @@ static int
GetWinFileLongName(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- Tcl_Obj *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
- return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);
+ return ConvertFileNameFormat(interp, objIndex, fileName, 1,
+ attributePtrPtr);
}
/*
@@ -1832,16 +1872,15 @@ GetWinFileLongName(
*
* GetWinFileShortName --
*
- * Returns a Tcl_Obj containing the short version of the file
- * name.
+ * Returns a Tcl_Obj containing the short version of the file name.
*
* Results:
- * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
- * will have ref count 0. If the return value is not TCL_OK,
- * attributePtrPtr is not touched.
+ * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
+ * have ref count 0. If the return value is not TCL_OK, attributePtrPtr
+ * is not touched.
*
* Side effects:
- * A new object is allocated if the file is valid.
+ * A new object is allocated if the file is valid.
*
*----------------------------------------------------------------------
*/
@@ -1850,10 +1889,11 @@ static int
GetWinFileShortName(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- Tcl_Obj *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
- return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);
+ return ConvertFileNameFormat(interp, objIndex, fileName, 0,
+ attributePtrPtr);
}
/*
@@ -1861,14 +1901,14 @@ GetWinFileShortName(
*
* SetWinFileAttributes --
*
- * Set the file attributes to the value given by attributePtr.
- * This routine sets the -hidden, -readonly, or -system attributes.
+ * Set the file attributes to the value given by attributePtr. This
+ * routine sets the -hidden, -readonly, or -system attributes.
*
* Results:
- * Standard TCL error.
+ * Standard TCL error.
*
* Side effects:
- * The file's attribute is set.
+ * The file's attribute is set.
*
*----------------------------------------------------------------------
*/
@@ -1877,7 +1917,7 @@ static int
SetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- Tcl_Obj *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes;
@@ -1917,14 +1957,13 @@ SetWinFileAttributes(
*
* SetWinFileLongName --
*
- * The attribute in question is a readonly attribute and cannot
- * be set.
+ * The attribute in question is a readonly attribute and cannot be set.
*
* Results:
- * TCL_ERROR
+ * TCL_ERROR
*
* Side effects:
- * The object result is set to a pertinent error message.
+ * The object result is set to a pertinent error message.
*
*----------------------------------------------------------------------
*/
@@ -1933,7 +1972,7 @@ static int
CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- Tcl_Obj *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
Tcl_AppendResult(interp, "cannot set attribute \"",
@@ -1979,11 +2018,11 @@ TclpObjListVolumes(void)
if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
/*
* GetVolumeInformation() will detects all drives, but causes
- * chattering on empty floppy drives. We only do this if
- * GetLogicalDriveStrings() didn't work. It has also been reported
- * that on some laptops it takes a while for GetVolumeInformation()
- * to return when pinging an empty floppy drive, another reason to
- * try to avoid calling it.
+ * chattering on empty floppy drives. We only do this if
+ * GetLogicalDriveStrings() didn't work. It has also been reported
+ * that on some laptops it takes a while for GetVolumeInformation() to
+ * return when pinging an empty floppy drive, another reason to try to
+ * avoid calling it.
*/
buf[1] = ':';
@@ -2005,7 +2044,15 @@ TclpObjListVolumes(void)
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
-
+
Tcl_IncrRefCount(resultPtr);
return resultPtr;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index d8f1f81..dc6d5a0 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -1,20 +1,20 @@
-/*
+/*
* tclWinFile.c --
*
- * This file contains temporary wrappers around UNIX file handling
- * functions. These wrappers map the UNIX functions to Win32 HANDLE-style
- * files, which can be manipulated through the Win32 console redirection
- * interfaces.
+ * This file contains temporary wrappers around UNIX file handling
+ * functions. These wrappers map the UNIX functions to Win32 HANDLE-style
+ * files, which can be manipulated through the Win32 console redirection
+ * interfaces.
*
* Copyright (c) 1995-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: tclWinFile.c,v 1.75 2005/06/22 21:24:01 dgp Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.76 2005/07/24 22:56:47 dkf Exp $
*/
-//#define _WIN32_WINNT 0x0500
+//#define _WIN32_WINNT 0x0500
#include "tclWinInt.h"
#include "tclFileSystem.h"
@@ -24,239 +24,276 @@
#include <lmaccess.h> /* For TclpGetUserHome(). */
/*
- * The number of 100-ns intervals between the Windows system epoch
- * (1601-01-01 on the proleptic Gregorian calendar) and the
- * Posix epoch (1970-01-01).
+ * The number of 100-ns intervals between the Windows system epoch (1601-01-01
+ * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01).
*/
-#define POSIX_EPOCH_AS_FILETIME 116444736000000000
+#define POSIX_EPOCH_AS_FILETIME 116444736000000000
/*
- * Declarations for 'link' related information. This information
- * should come with VC++ 6.0, but is not in some older SDKs.
- * In any case it is not well documented.
+ * Declarations for 'link' related information. This information should come
+ * with VC++ 6.0, but is not in some older SDKs. In any case it is not well
+ * documented.
*/
+
#ifndef IO_REPARSE_TAG_RESERVED_ONE
-# define IO_REPARSE_TAG_RESERVED_ONE 0x000000001
+# define IO_REPARSE_TAG_RESERVED_ONE 0x000000001
#endif
#ifndef IO_REPARSE_TAG_RESERVED_RANGE
-# define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001
+# define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001
#endif
#ifndef IO_REPARSE_TAG_VALID_VALUES
-# define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF
+# define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF
#endif
#ifndef IO_REPARSE_TAG_HSM
-# define IO_REPARSE_TAG_HSM 0x0C0000004
+# define IO_REPARSE_TAG_HSM 0x0C0000004
#endif
#ifndef IO_REPARSE_TAG_NSS
-# define IO_REPARSE_TAG_NSS 0x080000005
+# define IO_REPARSE_TAG_NSS 0x080000005
#endif
#ifndef IO_REPARSE_TAG_NSSRECOVER
-# define IO_REPARSE_TAG_NSSRECOVER 0x080000006
+# define IO_REPARSE_TAG_NSSRECOVER 0x080000006
#endif
#ifndef IO_REPARSE_TAG_SIS
-# define IO_REPARSE_TAG_SIS 0x080000007
+# define IO_REPARSE_TAG_SIS 0x080000007
#endif
#ifndef IO_REPARSE_TAG_DFS
-# define IO_REPARSE_TAG_DFS 0x080000008
+# define IO_REPARSE_TAG_DFS 0x080000008
#endif
#ifndef IO_REPARSE_TAG_RESERVED_ZERO
-# define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000
+# define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000
#endif
#ifndef FILE_FLAG_OPEN_REPARSE_POINT
-# define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000
+# define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000
#endif
#ifndef IO_REPARSE_TAG_MOUNT_POINT
-# define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003
+# define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003
#endif
#ifndef IsReparseTagValid
-# define IsReparseTagValid(x) (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE))
+# define IsReparseTagValid(x) \
+ (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE))
#endif
#ifndef IO_REPARSE_TAG_SYMBOLIC_LINK
-# define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO
+# define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO
#endif
#ifndef FILE_SPECIAL_ACCESS
-# define FILE_SPECIAL_ACCESS (FILE_ANY_ACCESS)
+# define FILE_SPECIAL_ACCESS (FILE_ANY_ACCESS)
#endif
#ifndef FSCTL_SET_REPARSE_POINT
-# define FSCTL_SET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
-# define FSCTL_GET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS)
-# define FSCTL_DELETE_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
+# define FSCTL_SET_REPARSE_POINT \
+ CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
+# define FSCTL_GET_REPARSE_POINT \
+ CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS)
+# define FSCTL_DELETE_REPARSE_POINT \
+ CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
#endif
-/*
- * Maximum reparse buffer info size. The max user defined reparse
- * data is 16KB, plus there's a header.
+/*
+ * Maximum reparse buffer info size. The max user defined reparse data is
+ * 16KB, plus there's a header.
*/
-#define MAX_REPARSE_SIZE 17000
+#define MAX_REPARSE_SIZE 17000
/*
- * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition.
- * This is found in winnt.h.
- *
- * IMPORTANT: caution when using this structure, since the actual
- * structures used will want to store a full path in the 'PathBuffer'
- * field, but there isn't room (there's only a single WCHAR!). Therefore
- * one must artificially create a larger space of memory and then cast it
- * to this type. We use the 'DUMMY_REPARSE_BUFFER' struct just below to
- * deal with this problem.
+ * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition. This is
+ * found in winnt.h.
+ *
+ * IMPORTANT: caution when using this structure, since the actual structures
+ * used will want to store a full path in the 'PathBuffer' field, but there
+ * isn't room (there's only a single WCHAR!). Therefore one must artificially
+ * create a larger space of memory and then cast it to this type. We use the
+ * 'DUMMY_REPARSE_BUFFER' struct just below to deal with this problem.
*/
-#define REPARSE_MOUNTPOINT_HEADER_SIZE 8
+#define REPARSE_MOUNTPOINT_HEADER_SIZE 8
#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
typedef struct _REPARSE_DATA_BUFFER {
- DWORD ReparseTag;
- WORD ReparseDataLength;
- WORD Reserved;
+ DWORD ReparseTag;
+ WORD ReparseDataLength;
+ WORD Reserved;
union {
- struct {
- WORD SubstituteNameOffset;
- WORD SubstituteNameLength;
- WORD PrintNameOffset;
- WORD PrintNameLength;
- WCHAR PathBuffer[1];
- } SymbolicLinkReparseBuffer;
- struct {
- WORD SubstituteNameOffset;
- WORD SubstituteNameLength;
- WORD PrintNameOffset;
- WORD PrintNameLength;
- WCHAR PathBuffer[1];
- } MountPointReparseBuffer;
- struct {
- BYTE DataBuffer[1];
- } GenericReparseBuffer;
+ struct {
+ WORD SubstituteNameOffset;
+ WORD SubstituteNameLength;
+ WORD PrintNameOffset;
+ WORD PrintNameLength;
+ WCHAR PathBuffer[1];
+ } SymbolicLinkReparseBuffer;
+ struct {
+ WORD SubstituteNameOffset;
+ WORD SubstituteNameLength;
+ WORD PrintNameOffset;
+ WORD PrintNameLength;
+ WCHAR PathBuffer[1];
+ } MountPointReparseBuffer;
+ struct {
+ BYTE DataBuffer[1];
+ } GenericReparseBuffer;
};
} REPARSE_DATA_BUFFER;
#endif
typedef struct {
REPARSE_DATA_BUFFER dummy;
- WCHAR dummyBuf[MAX_PATH*3];
+ WCHAR dummyBuf[MAX_PATH*3];
} DUMMY_REPARSE_BUFFER;
-#if defined(_MSC_VER) && ( _MSC_VER <= 1100 )
-#undef HAVE_NO_FINDEX_ENUMS
+#if defined(_MSC_VER) && (_MSC_VER <= 1100)
+#undef HAVE_NO_FINDEX_ENUMS
#define HAVE_NO_FINDEX_ENUMS
#elif !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0400)
-#undef HAVE_NO_FINDEX_ENUMS
+#undef HAVE_NO_FINDEX_ENUMS
#define HAVE_NO_FINDEX_ENUMS
#endif
#ifdef HAVE_NO_FINDEX_ENUMS
/* These two aren't in VC++ 5.2 headers */
typedef enum _FINDEX_INFO_LEVELS {
- FindExInfoStandard,
- FindExInfoMaxInfoLevel
+ FindExInfoStandard,
+ FindExInfoMaxInfoLevel
} FINDEX_INFO_LEVELS;
typedef enum _FINDEX_SEARCH_OPS {
- FindExSearchNameMatch,
- FindExSearchLimitToDirectories,
- FindExSearchLimitToDevices,
- FindExSearchMaxSearchOp
+ FindExSearchNameMatch,
+ FindExSearchLimitToDirectories,
+ FindExSearchLimitToDevices,
+ FindExSearchMaxSearchOp
} FINDEX_SEARCH_OPS;
#endif /* HAVE_NO_FINDEX_ENUMS */
-/* Other typedefs required by this code */
+/*
+ * Other typedefs required by this code.
+ */
static time_t ToCTime(FILETIME fileTime);
-static void FromCTime( time_t posixTime,
- FILETIME* fileTime );
+static void FromCTime(time_t posixTime, FILETIME *fileTime);
-typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
- (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
+typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC(
+ LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
-typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
- (LPVOID Buffer);
+typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC(LPVOID Buffer);
-typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
- (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
+typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC(
+ LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
/*
- * Declarations for local procedures defined in this file:
+ * Declarations for local functions defined in this file:
*/
-static int NativeAccess(CONST TCHAR *path, int mode);
-static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks);
-static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec);
-static int NativeIsExec(CONST TCHAR *path);
-static int NativeReadReparse(CONST TCHAR* LinkDirectory,
- REPARSE_DATA_BUFFER* buffer);
-static int NativeWriteReparse(CONST TCHAR* LinkDirectory,
- REPARSE_DATA_BUFFER* buffer);
-static int NativeMatchType(int isDrive, DWORD attr, CONST TCHAR* nativeName,
- Tcl_GlobTypeData *types);
-static int WinIsDrive(CONST char *name, int nameLen);
-static int WinIsReserved(CONST char *path);
-static Tcl_Obj* WinReadLink(CONST TCHAR* LinkSource);
-static Tcl_Obj* WinReadLinkDirectory(CONST TCHAR* LinkDirectory);
-static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget,
- int linkAction);
-static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory,
- CONST TCHAR* LinkTarget);
+static int NativeAccess(CONST TCHAR *path, int mode);
+static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr,
+ int checkLinks);
+static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec);
+static int NativeIsExec(CONST TCHAR *path);
+static int NativeReadReparse(CONST TCHAR *LinkDirectory,
+ REPARSE_DATA_BUFFER* buffer);
+static int NativeWriteReparse(CONST TCHAR *LinkDirectory,
+ REPARSE_DATA_BUFFER* buffer);
+static int NativeMatchType(int isDrive, DWORD attr,
+ CONST TCHAR *nativeName, Tcl_GlobTypeData *types);
+static int WinIsDrive(CONST char *name, int nameLen);
+static int WinIsReserved(CONST char *path);
+static Tcl_Obj * WinReadLink(CONST TCHAR *LinkSource);
+static Tcl_Obj * WinReadLinkDirectory(CONST TCHAR *LinkDirectory);
+static int WinLink(CONST TCHAR *LinkSource,
+ CONST TCHAR *LinkTarget, int linkAction);
+static int WinSymLinkDirectory(CONST TCHAR *LinkDirectory,
+ CONST TCHAR *LinkTarget);
/*
*--------------------------------------------------------------------
*
- * WinLink
+ * WinLink --
+ *
+ * Make a link from source to target.
*
- * Make a link from source to target.
*--------------------------------------------------------------------
*/
-static int
+
+static int
WinLink(LinkSource, LinkTarget, linkAction)
- CONST TCHAR* LinkSource;
- CONST TCHAR* LinkTarget;
+ CONST TCHAR *LinkSource;
+ CONST TCHAR *LinkTarget;
int linkAction;
{
- WCHAR tempFileName[MAX_PATH];
- TCHAR* tempFilePart;
- int attr;
-
- /* Get the full path referenced by the target */
- if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget,
- MAX_PATH, tempFileName, &tempFilePart)) {
- /* Invalid file */
+ WCHAR tempFileName[MAX_PATH];
+ TCHAR *tempFilePart;
+ int attr;
+
+ /*
+ * Get the full path referenced by the target.
+ */
+
+ if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget, MAX_PATH,
+ tempFileName, &tempFilePart)) {
+ /*
+ * Invalid file.
+ */
TclWinConvertError(GetLastError());
return -1;
}
- /* Make sure source file doesn't exist */
+ /*
+ * Make sure source file doesn't exist.
+ */
+
attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
if (attr != 0xffffffff) {
Tcl_SetErrno(EEXIST);
return -1;
}
- /* Get the full path referenced by the source file/directory */
- if (!(*tclWinProcs->getFullPathNameProc)(LinkSource,
- MAX_PATH, tempFileName, &tempFilePart)) {
- /* Invalid file */
+ /*
+ * Get the full path referenced by the source file/directory.
+ */
+
+ if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, MAX_PATH,
+ tempFileName, &tempFilePart)) {
+ /*
+ * Invalid file.
+ */
+
TclWinConvertError(GetLastError());
return -1;
}
- /* Check the target */
+
+ /*
+ * Check the target.
+ */
+
attr = (*tclWinProcs->getFileAttributesProc)(LinkTarget);
if (attr == 0xffffffff) {
- /* The target doesn't exist */
+ /*
+ * The target doesn't exist.
+ */
+
TclWinConvertError(GetLastError());
return -1;
+
} else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
- /* It is a file */
+ /*
+ * It is a file.
+ */
+
if (tclWinProcs->createHardLinkProc == NULL) {
Tcl_SetErrno(ENOTDIR);
return -1;
}
+
if (linkAction & TCL_CREATE_HARD_LINK) {
- if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) {
+ if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget,
+ NULL)) {
TclWinConvertError(GetLastError());
return -1;
}
return 0;
+
} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
- /* Can't symlink files */
+ /*
+ * Can't symlink files.
+ */
+
Tcl_SetErrno(ENOTDIR);
return -1;
} else {
@@ -266,8 +303,12 @@ WinLink(LinkSource, LinkTarget, linkAction)
} else {
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
return WinSymLinkDirectory(LinkSource, LinkTarget);
+
} else if (linkAction & TCL_CREATE_HARD_LINK) {
- /* Can't hard link directories */
+ /*
+ * Can't hard link directories.
+ */
+
Tcl_SetErrno(EISDIR);
return -1;
} else {
@@ -280,35 +321,53 @@ WinLink(LinkSource, LinkTarget, linkAction)
/*
*--------------------------------------------------------------------
*
- * WinReadLink
+ * WinReadLink --
+ *
+ * What does 'LinkSource' point to?
*
- * What does 'LinkSource' point to?
*--------------------------------------------------------------------
*/
-static Tcl_Obj*
+
+static Tcl_Obj*
WinReadLink(LinkSource)
- CONST TCHAR* LinkSource;
+ CONST TCHAR *LinkSource;
{
- WCHAR tempFileName[MAX_PATH];
- TCHAR* tempFilePart;
- int attr;
-
- /* Get the full path referenced by the target */
- if (!(*tclWinProcs->getFullPathNameProc)(LinkSource,
- MAX_PATH, tempFileName, &tempFilePart)) {
- /* Invalid file */
+ WCHAR tempFileName[MAX_PATH];
+ TCHAR *tempFilePart;
+ int attr;
+
+ /*
+ * Get the full path referenced by the target.
+ */
+
+ if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, MAX_PATH,
+ tempFileName, &tempFilePart)) {
+ /*
+ * Invalid file.
+ */
+
TclWinConvertError(GetLastError());
return NULL;
}
- /* Make sure source file does exist */
+ /*
+ * Make sure source file does exist.
+ */
+
attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
if (attr == 0xffffffff) {
- /* The source doesn't exist */
+ /*
+ * The source doesn't exist.
+ */
+
TclWinConvertError(GetLastError());
return NULL;
+
} else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
- /* It is a file - this is not yet supported */
+ /*
+ * It is a file - this is not yet supported.
+ */
+
Tcl_SetErrno(ENOTDIR);
return NULL;
} else {
@@ -319,84 +378,98 @@ WinReadLink(LinkSource)
/*
*--------------------------------------------------------------------
*
- * WinSymLinkDirectory
+ * WinSymLinkDirectory --
+ *
+ * This routine creates a NTFS junction, using the undocumented
+ * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points and
+ * junctions.
+ *
+ * Assumption that LinkTarget is a valid, existing directory.
*
- * This routine creates a NTFS junction, using the undocumented
- * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points
- * and junctions.
+ * Returns:
+ * Zero on success.
*
- * Assumption that LinkTarget is a valid, existing directory.
- *
- * Returns zero on success.
*--------------------------------------------------------------------
*/
-static int
+
+static int
WinSymLinkDirectory(LinkDirectory, LinkTarget)
- CONST TCHAR* LinkDirectory;
- CONST TCHAR* LinkTarget;
+ CONST TCHAR *LinkDirectory;
+ CONST TCHAR *LinkTarget;
{
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
- int len;
- WCHAR nativeTarget[MAX_PATH];
- WCHAR *loop;
-
- /* Make the native target name */
+ int len;
+ WCHAR nativeTarget[MAX_PATH];
+ WCHAR *loop;
+
+ /*
+ * Make the native target name.
+ */
+
memcpy((VOID*)nativeTarget, (VOID*)L"\\??\\", 4*sizeof(WCHAR));
- memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget,
+ memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget,
sizeof(WCHAR)*(1+wcslen((WCHAR*)LinkTarget)));
len = wcslen(nativeTarget);
- /*
- * We must have backslashes only. This is VERY IMPORTANT.
- * If we have any forward slashes everything appears to work,
- * but the resulting symlink is useless!
+
+ /*
+ * We must have backslashes only. This is VERY IMPORTANT. If we have any
+ * forward slashes everything appears to work, but the resulting symlink
+ * is useless!
*/
+
for (loop = nativeTarget; *loop != 0; loop++) {
if (*loop == L'/') *loop = L'\\';
}
if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) {
nativeTarget[len-1] = 0;
}
-
- /* Build the reparse info */
+
+ /*
+ * Build the reparse info.
+ */
+
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
- reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength =
- wcslen(nativeTarget) * sizeof(WCHAR);
+ reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength =
+ wcslen(nativeTarget) * sizeof(WCHAR);
reparseBuffer->Reserved = 0;
reparseBuffer->SymbolicLinkReparseBuffer.PrintNameLength = 0;
- reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset =
- reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength
- + sizeof(WCHAR);
- memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget,
- sizeof(WCHAR)
- + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength);
- reparseBuffer->ReparseDataLength =
- reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12;
-
+ reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset =
+ reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength
+ + sizeof(WCHAR);
+ memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget,
+ sizeof(WCHAR)
+ + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength);
+ reparseBuffer->ReparseDataLength =
+ reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12;
+
return NativeWriteReparse(LinkDirectory, reparseBuffer);
}
/*
*--------------------------------------------------------------------
*
- * TclWinSymLinkCopyDirectory
+ * TclWinSymLinkCopyDirectory --
+ *
+ * Copy a Windows NTFS junction. This function assumes that LinkOriginal
+ * exists and is a valid junction point, and that LinkCopy does not
+ * exist.
+ *
+ * Returns:
+ * Zero on success.
*
- * Copy a Windows NTFS junction. This function assumes that
- * LinkOriginal exists and is a valid junction point, and that
- * LinkCopy does not exist.
- *
- * Returns zero on success.
*--------------------------------------------------------------------
*/
-int
+
+int
TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy)
- CONST TCHAR* LinkOriginal; /* Existing junction - reparse point */
- CONST TCHAR* LinkCopy; /* Will become a duplicate junction */
+ CONST TCHAR *LinkOriginal; /* Existing junction - reparse point */
+ CONST TCHAR *LinkCopy; /* Will become a duplicate junction */
{
DUMMY_REPARSE_BUFFER dummy;
- REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
-
+ REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
+
if (NativeReadReparse(LinkOriginal, reparseBuffer)) {
return -1;
}
@@ -406,43 +479,53 @@ TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy)
/*
*--------------------------------------------------------------------
*
- * TclWinSymLinkDelete
+ * TclWinSymLinkDelete --
+ *
+ * Delete a Windows NTFS junction. Once the junction information is
+ * deleted, the filesystem object becomes an ordinary directory. Unless
+ * 'linkOnly' is given, that directory is also removed.
+ *
+ * Assumption that LinkOriginal is a valid, existing junction.
+ *
+ * Returns:
+ * Zero on success.
*
- * Delete a Windows NTFS junction. Once the junction information
- * is deleted, the filesystem object becomes an ordinary directory.
- * Unless 'linkOnly' is given, that directory is also removed.
- *
- * Assumption that LinkOriginal is a valid, existing junction.
- *
- * Returns zero on success.
*--------------------------------------------------------------------
*/
-int
+
+int
TclWinSymLinkDelete(LinkOriginal, linkOnly)
- CONST TCHAR* LinkOriginal;
+ CONST TCHAR *LinkOriginal;
int linkOnly;
{
- /* It is a symbolic link -- remove it */
+ /*
+ * It is a symbolic link - remove it.
+ */
+
DUMMY_REPARSE_BUFFER dummy;
- REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
+ REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
HANDLE hFile;
DWORD returnedLength;
+
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
hFile = (*tclWinProcs->createFileProc)(LinkOriginal, GENERIC_WRITE, 0,
- NULL, OPEN_EXISTING,
- FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+ NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+
if (hFile != INVALID_HANDLE_VALUE) {
- if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
- REPARSE_MOUNTPOINT_HEADER_SIZE,
- NULL, 0, &returnedLength, NULL)) {
- /* Error setting junction */
+ if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
+ REPARSE_MOUNTPOINT_HEADER_SIZE,NULL,0,&returnedLength,NULL)) {
+ /*
+ * Error setting junction.
+ */
+
TclWinConvertError(GetLastError());
CloseHandle(hFile);
} else {
CloseHandle(hFile);
if (!linkOnly) {
- (*tclWinProcs->removeDirectoryProc)(LinkOriginal);
+ (*tclWinProcs->removeDirectoryProc)(LinkOriginal);
}
return 0;
}
@@ -453,167 +536,196 @@ TclWinSymLinkDelete(LinkOriginal, linkOnly)
/*
*--------------------------------------------------------------------
*
- * WinReadLinkDirectory
+ * WinReadLinkDirectory --
*
- * This routine reads a NTFS junction, using the undocumented
- * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points
- * and junctions.
+ * This routine reads a NTFS junction, using the undocumented
+ * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points and
+ * junctions.
+ *
+ * Assumption that LinkDirectory is a valid, existing directory.
+ *
+ * Returns:
+ * A Tcl_Obj with refCount of 1 (i.e. owned by the caller), or NULL if
+ * anything went wrong.
+ *
+ * In the future we should enhance this to return a path object rather
+ * than a string.
*
- * Assumption that LinkDirectory is a valid, existing directory.
- *
- * Returns a Tcl_Obj with refCount of 1 (i.e. owned by the caller),
- * or NULL if anything went wrong.
- *
- * In the future we should enhance this to return a path object
- * rather than a string.
*--------------------------------------------------------------------
*/
-static Tcl_Obj*
+
+static Tcl_Obj*
WinReadLinkDirectory(LinkDirectory)
- CONST TCHAR* LinkDirectory;
+ CONST TCHAR *LinkDirectory;
{
int attr;
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
-
+
attr = (*tclWinProcs->getFileAttributesProc)(LinkDirectory);
if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
Tcl_SetErrno(EINVAL);
return NULL;
}
if (NativeReadReparse(LinkDirectory, reparseBuffer)) {
- return NULL;
+ return NULL;
}
-
+
switch (reparseBuffer->ReparseTag) {
- case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK:
- case IO_REPARSE_TAG_SYMBOLIC_LINK:
- case IO_REPARSE_TAG_MOUNT_POINT: {
- Tcl_Obj *retVal;
- Tcl_DString ds;
- CONST char *copy;
- int len;
- int offset = 0;
-
- /*
- * Certain native path representations on Windows have a
- * special prefix to indicate that they are to be treated
- * specially. For example extremely long paths, or symlinks,
- * or volumes mounted inside directories.
- *
- * There is an assumption in this code that 'wide' interfaces
- * are being used (see tclWin32Dll.c), which is true for the
- * only systems which support reparse tags at present. If
- * that changes in the future, this code will have to be
- * generalised.
+ case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK:
+ case IO_REPARSE_TAG_SYMBOLIC_LINK:
+ case IO_REPARSE_TAG_MOUNT_POINT: {
+ Tcl_Obj *retVal;
+ Tcl_DString ds;
+ CONST char *copy;
+ int len;
+ int offset = 0;
+
+ /*
+ * Certain native path representations on Windows have a special
+ * prefix to indicate that they are to be treated specially. For
+ * example extremely long paths, or symlinks, or volumes mounted
+ * inside directories.
+ *
+ * There is an assumption in this code that 'wide' interfaces are
+ * being used (see tclWin32Dll.c), which is true for the only systems
+ * which support reparse tags at present. If that changes in the
+ * future, this code will have to be generalised.
+ */
+
+ if (reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[0] == L'\\') {
+ /*
+ * Check whether this is a mounted volume.
*/
- if (reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[0]
- == L'\\') {
- /* Check whether this is a mounted volume */
- if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
- L"\\??\\Volume{",11) == 0) {
- char drive;
- /*
- * There is some confusion between \??\ and \\?\ which
- * we have to fix here. It doesn't seem very well
- * documented.
- */
- reparseBuffer->SymbolicLinkReparseBuffer
- .PathBuffer[1] = L'\\';
- /*
- * Check if a corresponding drive letter exists, and
- * use that if it is found
- */
- drive = TclWinDriveLetterForVolMountPoint(reparseBuffer
- ->SymbolicLinkReparseBuffer.PathBuffer);
- if (drive != -1) {
- char driveSpec[3] = {
- '\0', ':', '\0'
- };
- driveSpec[0] = drive;
- retVal = Tcl_NewStringObj(driveSpec,2);
- Tcl_IncrRefCount(retVal);
- return retVal;
- }
- /*
- * This is actually a mounted drive, which doesn't
- * exists as a DOS drive letter. This means the path
- * isn't actually a link, although we partially treat
- * it like one ('file type' will return 'link'), but
- * then the link will actually just be treated like
- * an ordinary directory. I don't believe any
- * serious inconsistency will arise from this, but it
- * is something to be aware of.
- */
- Tcl_SetErrno(EINVAL);
- return NULL;
- } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
- .PathBuffer, L"\\\\?\\",4) == 0) {
- /* Strip off the prefix */
- offset = 4;
- } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
- .PathBuffer, L"\\??\\",4) == 0) {
- /* Strip off the prefix */
- offset = 4;
+
+ if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
+ L"\\??\\Volume{",11) == 0) {
+ char drive;
+
+ /*
+ * There is some confusion between \??\ and \\?\ which we have
+ * to fix here. It doesn't seem very well documented.
+ */
+
+ reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[1] = L'\\';
+
+ /*
+ * Check if a corresponding drive letter exists, and use that
+ * if it is found
+ */
+
+ drive = TclWinDriveLetterForVolMountPoint(
+ reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer);
+ if (drive != -1) {
+ char driveSpec[3] = {
+ '\0', ':', '\0'
+ };
+
+ driveSpec[0] = drive;
+ retVal = Tcl_NewStringObj(driveSpec,2);
+ Tcl_IncrRefCount(retVal);
+ return retVal;
}
+
+ /*
+ * This is actually a mounted drive, which doesn't exists as a
+ * DOS drive letter. This means the path isn't actually a
+ * link, although we partially treat it like one ('file type'
+ * will return 'link'), but then the link will actually just
+ * be treated like an ordinary directory. I don't believe any
+ * serious inconsistency will arise from this, but it is
+ * something to be aware of.
+ */
+
+ Tcl_SetErrno(EINVAL);
+ return NULL;
+
+ } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
+ .PathBuffer, L"\\\\?\\",4) == 0) {
+ /*
+ * Strip off the prefix.
+ */
+
+ offset = 4;
+ } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
+ .PathBuffer, L"\\??\\",4) == 0) {
+ /*
+ * Strip off the prefix.
+ */
+ offset = 4;
}
-
- Tcl_WinTCharToUtf(
- (CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
- (int)reparseBuffer->SymbolicLinkReparseBuffer
- .SubstituteNameLength, &ds);
-
- copy = Tcl_DStringValue(&ds)+offset;
- len = Tcl_DStringLength(&ds)-offset;
- retVal = Tcl_NewStringObj(copy,len);
- Tcl_IncrRefCount(retVal);
- Tcl_DStringFree(&ds);
- return retVal;
}
+
+ Tcl_WinTCharToUtf((CONST char*)
+ reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
+ (int) reparseBuffer->SymbolicLinkReparseBuffer
+ .SubstituteNameLength, &ds);
+
+ copy = Tcl_DStringValue(&ds)+offset;
+ len = Tcl_DStringLength(&ds)-offset;
+ retVal = Tcl_NewStringObj(copy,len);
+ Tcl_IncrRefCount(retVal);
+ Tcl_DStringFree(&ds);
+ return retVal;
+ }
+ default:
+ Tcl_SetErrno(EINVAL);
+ return NULL;
}
- Tcl_SetErrno(EINVAL);
- return NULL;
}
/*
*--------------------------------------------------------------------
*
- * NativeReadReparse
+ * NativeReadReparse --
+ *
+ * Read the junction/reparse information from a given NTFS directory.
+ *
+ * Assumption that LinkDirectory is a valid, existing directory.
*
- * Read the junction/reparse information from a given NTFS directory.
+ * Returns:
+ * Zero on success.
*
- * Assumption that LinkDirectory is a valid, existing directory.
- *
- * Returns zero on success.
*--------------------------------------------------------------------
*/
-static int
+
+static int
NativeReadReparse(LinkDirectory, buffer)
- CONST TCHAR* LinkDirectory; /* The junction to read */
- REPARSE_DATA_BUFFER* buffer; /* Pointer to buffer. Cannot be NULL */
+ CONST TCHAR *LinkDirectory; /* The junction to read */
+ REPARSE_DATA_BUFFER *buffer;/* Pointer to buffer. Cannot be NULL */
{
HANDLE hFile;
DWORD returnedLength;
-
+
hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_READ, 0,
- NULL, OPEN_EXISTING,
- FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+ NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+
if (hFile == INVALID_HANDLE_VALUE) {
- /* Error creating directory */
+ /*
+ * Error creating directory.
+ */
+
TclWinConvertError(GetLastError());
return -1;
}
- /* Get the link */
- if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL,
- 0, buffer, sizeof(DUMMY_REPARSE_BUFFER),
- &returnedLength, NULL)) {
- /* Error setting junction */
+
+ /*
+ * Get the link.
+ */
+
+ if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer,
+ sizeof(DUMMY_REPARSE_BUFFER), &returnedLength, NULL)) {
+ /*
+ * Error setting junction.
+ */
+
TclWinConvertError(GetLastError());
CloseHandle(hFile);
return -1;
}
CloseHandle(hFile);
-
+
if (!IsReparseTagValid(buffer->ReparseTag)) {
Tcl_SetErrno(EINVAL);
return -1;
@@ -624,48 +736,69 @@ NativeReadReparse(LinkDirectory, buffer)
/*
*--------------------------------------------------------------------
*
- * NativeWriteReparse
+ * NativeWriteReparse --
+ *
+ * Write the reparse information for a given directory.
+ *
+ * Assumption that LinkDirectory does not exist.
*
- * Write the reparse information for a given directory.
- *
- * Assumption that LinkDirectory does not exist.
*--------------------------------------------------------------------
*/
-static int
+
+static int
NativeWriteReparse(LinkDirectory, buffer)
- CONST TCHAR* LinkDirectory;
+ CONST TCHAR *LinkDirectory;
REPARSE_DATA_BUFFER* buffer;
{
HANDLE hFile;
DWORD returnedLength;
-
- /* Create the directory - it must not already exist */
+
+ /*
+ * Create the directory - it must not already exist.
+ */
+
if ((*tclWinProcs->createDirectoryProc)(LinkDirectory, NULL) == 0) {
- /* Error creating directory */
+ /*
+ * Error creating directory.
+ */
+
TclWinConvertError(GetLastError());
return -1;
}
+
hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_WRITE, 0,
- NULL, OPEN_EXISTING,
- FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+ NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
- /* Error creating directory */
+ /*
+ * Error creating directory.
+ */
TclWinConvertError(GetLastError());
return -1;
}
- /* Set the link */
- if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer,
- (DWORD) buffer->ReparseDataLength
- + REPARSE_MOUNTPOINT_HEADER_SIZE,
- NULL, 0, &returnedLength, NULL)) {
- /* Error setting junction */
+
+ /*
+ * Set the link.
+ */
+
+ if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer,
+ (DWORD) buffer->ReparseDataLength + REPARSE_MOUNTPOINT_HEADER_SIZE,
+ NULL, 0, &returnedLength, NULL)) {
+ /*
+ * Error setting junction.
+ */
+
TclWinConvertError(GetLastError());
CloseHandle(hFile);
(*tclWinProcs->removeDirectoryProc)(LinkDirectory);
return -1;
}
CloseHandle(hFile);
- /* We succeeded */
+
+ /*
+ * We succeeded.
+ */
+
return 0;
}
@@ -674,11 +807,11 @@ NativeWriteReparse(LinkDirectory, buffer)
*
* TclpFindExecutable --
*
- * This procedure computes the absolute path name of the current
+ * This function computes the absolute path name of the current
* application.
*
* Results:
- * None.
+ * None.
*
* Side effects:
* The computed path is stored.
@@ -701,11 +834,14 @@ TclpFindExecutable(argv0)
if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) {
GetModuleFileNameA(NULL, name, sizeof(name));
+
/*
* Convert to WCHAR to get out of ANSI codepage
*/
+
MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH);
}
+
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
TclWinNoBackslash(name);
TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL);
@@ -716,25 +852,25 @@ TclpFindExecutable(argv0)
*
* TclpMatchInDirectory --
*
- * This routine is used by the globbing code to search a
- * directory for all files which match a given pattern.
+ * This routine is used by the globbing code to search a directory for
+ * all files which match a given pattern.
*
- * Results:
- *
- * The return value is a standard Tcl result indicating whether an
- * error occurred in globbing. Errors are left in interp, good
- * results are lappended to resultPtr (which must be a valid object)
+ * Results:
+ * The return value is a standard Tcl result indicating whether an error
+ * occurred in globbing. Errors are left in interp, good results are
+ * lappended to resultPtr (which must be a valid object).
*
* Side effects:
* None.
*
- *---------------------------------------------------------------------- */
+ *----------------------------------------------------------------------
+ */
int
TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
Tcl_Interp *interp; /* Interpreter to receive errors. */
Tcl_Obj *resultPtr; /* List object to lappend results. */
- Tcl_Obj *pathPtr; /* Contains path to directory to search. */
+ Tcl_Obj *pathPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
* May be NULL. In particular the directory
@@ -743,20 +879,26 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
CONST TCHAR *native;
if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
- /* The native filesystem never adds mounts */
+ /*
+ * The native filesystem never adds mounts.
+ */
+
return TCL_OK;
}
if (pattern == NULL || (*pattern == '\0')) {
Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
- /* Match a single file directly */
+ /*
+ * Match a single file directly.
+ */
+
int len;
DWORD attr;
CONST char *str = Tcl_GetStringFromObj(norm,&len);
- native = (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr);
-
+ native = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr);
+
if (tclWinProcs->getFileAttributesExProc == NULL) {
attr = (*tclWinProcs->getFileAttributesProc)(native);
if (attr == 0xffffffff) {
@@ -770,8 +912,8 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
}
attr = data.dwFileAttributes;
}
- if (NativeMatchType(WinIsDrive(str,len), attr,
- native, types)) {
+
+ if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
}
@@ -780,19 +922,19 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
DWORD attr;
HANDLE handle;
WIN32_FIND_DATAT data;
- CONST char *dirName; /* utf-8 dir name, later
- * with pattern appended */
+ CONST char *dirName; /* UTF-8 dir name, later with pattern
+ * appended. */
int dirLength;
int matchSpecialDots;
- Tcl_DString ds; /* native encoding of dir, also used
- * temporarily for other things. */
- Tcl_DString dsOrig; /* utf-8 encoding of dir */
+ Tcl_DString ds; /* Native encoding of dir, also used
+ * temporarily for other things. */
+ Tcl_DString dsOrig; /* UTF-8 encoding of dir. */
Tcl_Obj *fileNamePtr;
char lastChar;
/*
- * Get the normalized path representation
- * (the main thing is we dont want any '~' sequences).
+ * Get the normalized path representation (the main thing is we dont
+ * want any '~' sequences).
*/
fileNamePtr = Tcl_FSGetNormalizedPath(interp, pathPtr);
@@ -801,9 +943,9 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
}
/*
- * Verify that the specified path exists and
- * is actually a directory.
+ * Verify that the specified path exists and is actually a directory.
*/
+
native = Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return TCL_OK;
@@ -814,15 +956,15 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
return TCL_OK;
}
- /*
- * Build up the directory name for searching, including
- * a trailing directory separator.
+ /*
+ * Build up the directory name for searching, including a trailing
+ * directory separator.
*/
Tcl_DStringInit(&dsOrig);
dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
-
+
lastChar = dirName[dirLength -1];
if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) {
Tcl_DStringAppend(&dsOrig, "/", 1);
@@ -831,68 +973,74 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
dirName = Tcl_DStringValue(&dsOrig);
/*
- * We need to check all files in the directory, so we append
- * '*.*' to the path, unless the pattern we've been given is
- * rather simple, when we can use that instead.
+ * We need to check all files in the directory, so we append '*.*' to
+ * the path, unless the pattern we've been given is rather simple,
+ * when we can use that instead.
*/
if (strpbrk(pattern, "[]\\") == NULL) {
- /*
+ /*
* The pattern is a simple one containing just '*' and/or '?'.
- * This means we can get the OS to help us, by passing
- * it the pattern.
+ * This means we can get the OS to help us, by passing it the
+ * pattern.
*/
+
dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
} else {
dirName = Tcl_DStringAppend(&dsOrig, "*.*", 3);
}
+
native = Tcl_WinUtfToTChar(dirName, -1, &ds);
- if (tclWinProcs->findFirstFileExProc == NULL
- || (types == NULL)
- || (types->type != TCL_GLOB_TYPE_DIR)) {
+ if (tclWinProcs->findFirstFileExProc == NULL || (types == NULL)
+ || (types->type != TCL_GLOB_TYPE_DIR)) {
handle = (*tclWinProcs->findFirstFileProc)(native, &data);
} else {
- /* We can be more efficient, for pure directory requests */
- handle = (*tclWinProcs->findFirstFileExProc)(native,
- FindExInfoStandard, &data,
- FindExSearchLimitToDirectories, NULL, 0);
+ /*
+ * We can be more efficient, for pure directory requests.
+ */
+
+ handle = (*tclWinProcs->findFirstFileExProc)(native,
+ FindExInfoStandard, &data,
+ FindExSearchLimitToDirectories, NULL, 0);
}
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
Tcl_DStringFree(&ds);
if (err == ERROR_FILE_NOT_FOUND) {
- /*
- * We used our 'pattern' above, and matched nothing
- * This means we just return TCL_OK, indicating
- * no results found.
- */
+ /*
+ * We used our 'pattern' above, and matched nothing. This
+ * means we just return TCL_OK, indicating no results found.
+ */
+
Tcl_DStringFree(&dsOrig);
return TCL_OK;
}
+
TclWinConvertError(err);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read directory \"",
- Tcl_DStringValue(&dsOrig), "\": ",
+ Tcl_DStringValue(&dsOrig), "\": ",
Tcl_PosixError(interp), (char *) NULL);
Tcl_DStringFree(&dsOrig);
return TCL_ERROR;
}
Tcl_DStringFree(&ds);
- /*
- * We may use this later, so we must restore it to its
- * length including the directory delimiter
+ /*
+ * We may use this later, so we must restore it to its length
+ * including the directory delimiter.
*/
+
Tcl_DStringSetLength(&dsOrig, dirLength);
/*
- * Check to see if the pattern should match the special
- * . and .. names, referring to the current directory,
- * or the directory above. We need a special check for
- * this because paths beginning with a dot are not considered
- * hidden on Windows, and so otherwise a relative glob like
- * 'glob -join * *' will actually return './. ../..' etc.
+ * Check to see if the pattern should match the special . and
+ * .. names, referring to the current directory, or the directory
+ * above. We need a special check for this because paths beginning
+ * with a dot are not considered hidden on Windows, and so otherwise a
+ * relative glob like 'glob -join * *' will actually return
+ * './. ../..' etc.
*/
if ((pattern[0] == '.')
@@ -903,8 +1051,8 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
}
/*
- * Now iterate over all of the files in the directory, starting
- * with the first one we found.
+ * Now iterate over all of the files in the directory, starting with
+ * the first one we found.
*/
do {
@@ -912,7 +1060,7 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
int checkDrive = 0;
int isDrive;
DWORD attr;
-
+
if (tclWinProcs->useWide) {
native = (CONST TCHAR *) data.w.cFileName;
attr = data.w.dwFileAttributes;
@@ -920,34 +1068,37 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
native = (CONST TCHAR *) data.a.cFileName;
attr = data.a.dwFileAttributes;
}
-
+
utfname = Tcl_WinTCharToUtf(native, -1, &ds);
if (!matchSpecialDots) {
- /* If it is exactly '.' or '..' then we ignore it */
- if ((utfname[0] == '.') && (utfname[1] == '\0'
+ /*
+ * If it is exactly '.' or '..' then we ignore it.
+ */
+
+ if ((utfname[0] == '.') && (utfname[1] == '\0'
|| (utfname[1] == '.' && utfname[2] == '\0'))) {
Tcl_DStringFree(&ds);
continue;
}
} else if (utfname[0] == '.' && utfname[1] == '.'
&& utfname[2] == '\0') {
- /*
- * Have to check if this is a drive below, so we can
- * correctly match 'hidden' and not hidden files.
+ /*
+ * Have to check if this is a drive below, so we can correctly
+ * match 'hidden' and not hidden files.
*/
+
checkDrive = 1;
}
-
+
/*
- * Check to see if the file matches the pattern. Note that
- * we are ignoring the case sensitivity flag because Windows
- * doesn't honor case even if the volume is case sensitive.
- * If the volume also doesn't preserve case, then we
- * previously returned the lower case form of the name. This
- * didn't seem quite right since there are
- * non-case-preserving volumes that actually return mixed
- * case. So now we are returning exactly what we get from
+ * Check to see if the file matches the pattern. Note that we are
+ * ignoring the case sensitivity flag because Windows doesn't
+ * honor case even if the volume is case sensitive. If the volume
+ * also doesn't preserve case, then we previously returned the
+ * lower case form of the name. This didn't seem quite right since
+ * there are non-case-preserving volumes that actually return
+ * mixed case. So now we are returning exactly what we get from
* the system.
*/
@@ -966,7 +1117,7 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
isDrive = 0;
}
if (NativeMatchType(isDrive, attr, native, types)) {
- Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_ListObjAppendElement(interp, resultPtr,
TclNewFSPathObj(pathPtr, utfname,
Tcl_DStringLength(&ds)));
}
@@ -975,6 +1126,7 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
/*
* Free ds here to ensure that native is valid above.
*/
+
Tcl_DStringFree(&ds);
} while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE);
@@ -984,23 +1136,27 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
}
}
-/*
- * Does the given path represent a root volume? We need this special
- * case because for NTFS root volumes, the getFileAttributesProc returns
- * a 'hidden' attribute when it should not.
+/*
+ * Does the given path represent a root volume? We need this special case
+ * because for NTFS root volumes, the getFileAttributesProc returns a 'hidden'
+ * attribute when it should not.
*/
+
static int
WinIsDrive(
- CONST char *name, /* Name (UTF-8) */
- int len) /* Length of name */
+ CONST char *name, /* Name (UTF-8) */
+ int len) /* Length of name */
{
int remove = 0;
while (len > 4) {
- if ((name[len-1] != '.' || name[len-2] != '.')
- || (name[len-3] != '/' && name[len-3] != '\\')) {
- /* We don't have '/..' at the end */
+ if ((name[len-1] != '.' || name[len-2] != '.')
+ || (name[len-3] != '/' && name[len-3] != '\\')) {
+ /*
+ * We don't have '/..' at the end.
+ */
+
if (remove == 0) {
- break;
+ break;
}
remove--;
while (len > 0) {
@@ -1010,74 +1166,94 @@ WinIsDrive(
}
}
if (len < 4) {
- len++;
+ len++;
break;
}
- } else {
- /* We do have '/..' */
+ } else {
+ /*
+ * We do have '/..'
+ */
+
len -= 3;
remove++;
- }
+ }
}
+
if (len < 4) {
if (len == 0) {
- /*
- * Not sure if this is possible, but we pass it on
- * anyway
+ /*
+ * Not sure if this is possible, but we pass it on anyway.
*/
} else if (len == 1 && (name[0] == '/' || name[0] == '\\')) {
- /* Path is pointing to the root volume */
+ /*
+ * Path is pointing to the root volume.
+ */
+
return 1;
- } else if ((name[1] == ':')
+ } else if ((name[1] == ':')
&& (len == 2 || (name[2] == '/' || name[2] == '\\'))) {
- /* Path is of the form 'x:' or 'x:/' or 'x:\' */
+ /*
+ * Path is of the form 'x:' or 'x:/' or 'x:\'
+ */
+
return 1;
}
}
+
return 0;
}
-/*
- * Does the given path represent a reserved window path name? If not
- * return 0, if true, return the number of characters of the path that
- * we actually want (not any trailing :).
+/*
+ * Does the given path represent a reserved window path name? If not return 0,
+ * if true, return the number of characters of the path that we actually want
+ * (not any trailing :).
*/
+
static int WinIsReserved(
- CONST char *path) /* Path in UTF-8 */
+ CONST char *path) /* Path in UTF-8 */
{
- if ((path[0] == 'c' || path[0] == 'C')
- && (path[1] == 'o' || path[1] == 'O')) {
+ if ((path[0] == 'c' || path[0] == 'C')
+ && (path[1] == 'o' || path[1] == 'O')) {
if ((path[2] == 'm' || path[2] == 'M')
- && path[3] >= '1' && path[3] <= '4') {
- /* May have match for 'com[1-4]:?', which is a serial port */
+ && path[3] >= '1' && path[3] <= '4') {
+ /*
+ * May have match for 'com[1-4]:?', which is a serial port.
+ */
+
if (path[4] == '\0') {
return 4;
} else if (path [4] == ':' && path[5] == '\0') {
return 4;
}
} else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
- /* Have match for 'con' */
+ /*
+ * Have match for 'con'
+ */
+
return 3;
}
+
} else if ((path[0] == 'l' || path[0] == 'L')
- && (path[1] == 'p' || path[1] == 'P')
- && (path[2] == 't' || path[2] == 'T')) {
+ && (path[1] == 'p' || path[1] == 'P')
+ && (path[2] == 't' || path[2] == 'T')) {
if (path[3] >= '1' && path[3] <= '3') {
- /* May have match for 'lpt[1-3]:?' */
+ /*
+ * May have match for 'lpt[1-3]:?'
+ */
+
if (path[4] == '\0') {
return 4;
} else if (path [4] == ':' && path[5] == '\0') {
return 4;
}
}
- } else if (stricmp(path, "prn") == 0) {
- /* Have match for 'prn' */
- return 3;
- } else if (stricmp(path, "nul") == 0) {
- /* Have match for 'nul' */
- return 3;
- } else if (stricmp(path, "aux") == 0) {
- /* Have match for 'aux' */
+
+ } else if (!stricmp(path, "prn") || !stricmp(path, "nul")
+ || !stricmp(path, "aux")) {
+ /*
+ * Have match for 'prn', 'nul' or 'aux'.
+ */
+
return 3;
}
return 0;
@@ -1085,102 +1261,106 @@ static int WinIsReserved(
/*
*----------------------------------------------------------------------
- *
+ *
* NativeMatchType --
- *
- * This function needs a special case for a path which is a root
- * volume, because for NTFS root volumes, the getFileAttributesProc
- * returns a 'hidden' attribute when it should not.
- *
- * We never make any calss to a 'get attributes' routine here,
- * since we have arranged things so that our caller already knows
- * such information.
- *
+ *
+ * This function needs a special case for a path which is a root volume,
+ * because for NTFS root volumes, the getFileAttributesProc returns a
+ * 'hidden' attribute when it should not.
+ *
+ * We never make any calss to a 'get attributes' routine here, since we
+ * have arranged things so that our caller already knows such
+ * information.
+ *
* Results:
- * 0 = file doesn't match
- * 1 = file matches
- *
+ * 0 = file doesn't match
+ * 1 = file matches
+ *
*----------------------------------------------------------------------
*/
-static int
+
+static int
NativeMatchType(
- int isDrive, /* Is this a drive */
- DWORD attr, /* We already know the attributes
- * for the file */
- CONST TCHAR* nativeName, /* Native path to check */
- Tcl_GlobTypeData *types) /* Type description to match against */
+ int isDrive, /* Is this a drive. */
+ DWORD attr, /* We already know the attributes for the
+ * file. */
+ CONST TCHAR *nativeName, /* Native path to check. */
+ Tcl_GlobTypeData *types) /* Type description to match against. */
{
/*
- * 'attr' represents the attributes of the file, but we only
- * want to retrieve this info if it is absolutely necessary
- * because it is an expensive call. Unfortunately, to deal
- * with hidden files properly, we must always retrieve it.
+ * 'attr' represents the attributes of the file, but we only want to
+ * retrieve this info if it is absolutely necessary because it is an
+ * expensive call. Unfortunately, to deal with hidden files properly, we
+ * must always retrieve it.
*/
if (types == NULL) {
- /* If invisible, don't return the file */
+ /*
+ * If invisible, don't return the file.
+ */
if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
return 0;
}
} else {
if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
- /* If invisible */
- if ((types->perm == 0) ||
- !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
+ /*
+ * If invisible.
+ */
+
+ if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
return 0;
}
} else {
- /* Visible */
+ /*
+ * Visible.
+ */
if (types->perm & TCL_GLOB_PERM_HIDDEN) {
return 0;
}
}
-
+
if (types->perm != 0) {
- if (
- ((types->perm & TCL_GLOB_PERM_RONLY) &&
+ if (((types->perm & TCL_GLOB_PERM_RONLY) &&
!(attr & FILE_ATTRIBUTE_READONLY)) ||
- ((types->perm & TCL_GLOB_PERM_R) &&
+ ((types->perm & TCL_GLOB_PERM_R) &&
(0 /* File exists => R_OK on Windows */)) ||
- ((types->perm & TCL_GLOB_PERM_W) &&
+ ((types->perm & TCL_GLOB_PERM_W) &&
(attr & FILE_ATTRIBUTE_READONLY)) ||
- ((types->perm & TCL_GLOB_PERM_X) &&
+ ((types->perm & TCL_GLOB_PERM_X) &&
(!(attr & FILE_ATTRIBUTE_DIRECTORY)
- && !NativeIsExec(nativeName)))
- ) {
+ && !NativeIsExec(nativeName)))) {
return 0;
}
}
- if ((types->type & TCL_GLOB_TYPE_DIR)
- && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
- /* Quicker test for directory, which is a common case */
+ if ((types->type & TCL_GLOB_TYPE_DIR)
+ && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
+ /*
+ * Quicker test for directory, which is a common case.
+ */
+
return 1;
+
} else if (types->type != 0) {
unsigned short st_mode;
int isExec = NativeIsExec(nativeName);
-
+
st_mode = NativeStatMode(attr, 0, isExec);
/*
* In order bcdpfls as in 'find -t'
*/
- if (
- ((types->type & TCL_GLOB_TYPE_BLOCK) &&
- S_ISBLK(st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_CHAR) &&
- S_ISCHR(st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_DIR) &&
- S_ISDIR(st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_PIPE) &&
- S_ISFIFO(st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_FILE) &&
- S_ISREG(st_mode))
+
+ if (((types->type&TCL_GLOB_TYPE_BLOCK) && S_ISBLK(st_mode)) ||
+ ((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) ||
+ ((types->type&TCL_GLOB_TYPE_DIR) && S_ISDIR(st_mode)) ||
+ ((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) ||
#ifdef S_ISSOCK
- || ((types->type & TCL_GLOB_TYPE_SOCK) &&
- S_ISSOCK(st_mode))
+ ((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) ||
#endif
- ) {
- /* Do nothing -- this file is ok */
+ ((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) {
+ /*
+ * Do nothing - this file is ok.
+ */
} else {
#ifdef S_ISLNK
if (types->type & TCL_GLOB_TYPE_LINK) {
@@ -1192,8 +1372,8 @@ NativeMatchType(
#endif
return 0;
}
- }
- }
+ }
+ }
return 1;
}
@@ -1208,9 +1388,9 @@ NativeMatchType(
* Results:
* The result is a pointer to a string specifying the user's home
* directory, or NULL if the user's home directory could not be
- * determined. Storage for the result string is allocated in
- * bufferPtr; the caller must call Tcl_DStringFree() when the result
- * is no longer needed.
+ * determined. Storage for the result string is allocated in bufferPtr;
+ * the caller must call Tcl_DStringFree() when the result is no longer
+ * needed.
*
* Side effects:
* None.
@@ -1239,9 +1419,9 @@ TclpGetUserHome(name, bufferPtr)
netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
GetProcAddress(netapiInst, "NetApiBufferFree");
- netGetDCNameProc = (NETGETDCNAMEPROC *)
+ netGetDCNameProc = (NETGETDCNAMEPROC *)
GetProcAddress(netapiInst, "NetGetDCName");
- netUserGetInfoProc = (NETUSERGETINFOPROC *)
+ netUserGetInfoProc = (NETUSERGETINFOPROC *)
GetProcAddress(netapiInst, "NetUserGetInfo");
if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
&& (netApiBufferFreeProc != NULL)) {
@@ -1274,8 +1454,8 @@ TclpGetUserHome(name, bufferPtr)
Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
bufferPtr);
} else {
- /*
- * User exists but has no home dir. Return
+ /*
+ * User exists but has no home dir. Return
* "{Windows Drive}:/users/default".
*/
@@ -1296,20 +1476,20 @@ TclpGetUserHome(name, bufferPtr)
}
if (result == NULL) {
/*
- * Look in the "Password Lists" section of system.ini for the
- * local user. There are also entries in that section that begin
- * with a "*" character that are used by Windows for other
- * purposes; ignore user names beginning with a "*".
+ * Look in the "Password Lists" section of system.ini for the local
+ * user. There are also entries in that section that begin with a "*"
+ * character that are used by Windows for other purposes; ignore user
+ * names beginning with a "*".
*/
char buf[MAX_PATH];
if (name[0] != '*') {
- if (GetPrivateProfileStringA("Password Lists", name, "", buf,
+ if (GetPrivateProfileStringA("Password Lists", name, "", buf,
MAX_PATH, "system.ini") > 0) {
- /*
- * User exists, but there is no such thing as a home
- * directory in system.ini. Return "{Windows drive}:/".
+ /*
+ * User exists, but there is no such thing as a home directory
+ * in system.ini. Return "{Windows drive}:/".
*/
GetWindowsDirectoryA(buf, MAX_PATH);
@@ -1329,7 +1509,7 @@ TclpGetUserHome(name, bufferPtr)
*
* This function replaces the library version of access(), fixing the
* following bugs:
- *
+ *
* 1. access() returns that all files have execute permission.
*
* Results:
@@ -1343,8 +1523,7 @@ TclpGetUserHome(name, bufferPtr)
static int
NativeAccess(nativePath, mode)
- CONST TCHAR *nativePath; /* Path of file to access, native
- * encoding. */
+ CONST TCHAR *nativePath; /* Path of file to access, native encoding. */
int mode; /* Permission setting. */
{
DWORD attr;
@@ -1353,7 +1532,7 @@ NativeAccess(nativePath, mode)
if (attr == 0xffffffff) {
/*
- * File doesn't exist.
+ * File doesn't exist.
*/
TclWinConvertError(GetLastError());
@@ -1364,6 +1543,7 @@ NativeAccess(nativePath, mode)
/*
* File is not writable.
*/
+
Tcl_SetErrno(EACCES);
return -1;
}
@@ -1371,27 +1551,26 @@ NativeAccess(nativePath, mode)
if (mode & X_OK) {
if (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativePath)) {
/*
- * It's not a directory and doesn't have the correct
- * extension. Therefore it can't be executable
+ * It's not a directory and doesn't have the correct extension.
+ * Therefore it can't be executable
*/
+
Tcl_SetErrno(EACCES);
return -1;
}
}
- /*
- * It looks as if the permissions are ok, but if we are on NT, 2000
- * or XP, we have a more complex permissions structure so we try to
- * check that. The code below is remarkably complex for such a
- * simple thing as finding what permissions the OS has set for a
- * file.
- *
- * If we are simply checking for file existence, then we don't
- * need all these complications (which are really quite slow:
- * with this code 'file readable' is 5-6 times slower than 'file
- * exists').
+ /*
+ * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
+ * we have a more complex permissions structure so we try to check that.
+ * The code below is remarkably complex for such a simple thing as finding
+ * what permissions the OS has set for a file.
+ *
+ * If we are simply checking for file existence, then we don't need all
+ * these complications (which are really quite slow: with this code 'file
+ * readable' is 5-6 times slower than 'file exists').
*/
-
+
if ((mode != F_OK) && (tclWinProcs->getFileSecurityProc != NULL)) {
SECURITY_DESCRIPTOR *sdPtr = NULL;
unsigned long size;
@@ -1403,74 +1582,80 @@ NativeAccess(nativePath, mode)
PRIVILEGE_SET privSet;
DWORD privSetSize = sizeof(PRIVILEGE_SET);
int error;
-
- /*
- * First find out how big the buffer needs to be
+
+ /*
+ * First find out how big the buffer needs to be
*/
+
size = 0;
- (*tclWinProcs->getFileSecurityProc)(nativePath,
- OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
+ (*tclWinProcs->getFileSecurityProc)(nativePath,
+ OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION, 0, 0, &size);
- /*
- * Should have failed with ERROR_INSUFFICIENT_BUFFER
+ /*
+ * Should have failed with ERROR_INSUFFICIENT_BUFFER
*/
+
error = GetLastError();
if (error != ERROR_INSUFFICIENT_BUFFER) {
- /*
- * Most likely case is ERROR_ACCESS_DENIED, which
- * we will convert to EACCES - just what we want!
+ /*
+ * Most likely case is ERROR_ACCESS_DENIED, which we will convert
+ * to EACCES - just what we want!
*/
+
TclWinConvertError(error);
return -1;
}
- /*
- * Now size contains the size of buffer needed
+ /*
+ * Now size contains the size of buffer needed
*/
+
sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size);
if (sdPtr == NULL) {
goto accessError;
}
- /*
- * Call GetFileSecurity() for real
+ /*
+ * Call GetFileSecurity() for real
*/
- if (!(*tclWinProcs->getFileSecurityProc)(nativePath,
- OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
+
+ if (!(*tclWinProcs->getFileSecurityProc)(nativePath,
+ OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION, sdPtr, size, &size)) {
- /*
+ /*
* Error getting owner SD
*/
goto accessError;
}
- /*
+ /*
* Perform security impersonation of the user and open the
* resulting thread token.
*/
if (!(*tclWinProcs->impersonateSelfProc)(SecurityImpersonation)) {
- /*
- * Unable to perform security impersonation.
+ /*
+ * Unable to perform security impersonation.
*/
goto accessError;
}
- if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread (),
+ if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread (),
TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) {
- /*
- * Unable to get current thread's token.
+ /*
+ * Unable to get current thread's token.
*/
goto accessError;
}
(*tclWinProcs->revertToSelfProc)();
-
+
memset (&genMap, 0x00, sizeof (GENERIC_MAPPING));
-
- /*
- * Setup desiredAccess according to the access priveleges we
- * are checking.
+
+ /*
+ * Setup desiredAccess according to the access priveleges we are
+ * checking.
*/
+
genMap.GenericAll = 0;
if (mode & R_OK) {
desiredAccess |= FILE_GENERIC_READ;
@@ -1482,28 +1667,32 @@ NativeAccess(nativePath, mode)
desiredAccess |= FILE_GENERIC_EXECUTE;
}
- /*
- * Perform access check using the token.
+ /*
+ * Perform access check using the token.
*/
- if (!(*tclWinProcs->accessCheckProc )(sdPtr, hToken, desiredAccess,
+
+ if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess,
&genMap, &privSet, &privSetSize, &grantedAccess,
&accessYesNo)) {
- /*
- * Unable to perform access check.
+ /*
+ * Unable to perform access check.
*/
- accessError:
+
+ accessError:
TclWinConvertError(GetLastError());
if (sdPtr != NULL) {
- HeapFree(GetProcessHeap(), 0, sdPtr);
+ HeapFree(GetProcessHeap(), 0, sdPtr);
}
if (hToken != NULL) {
- CloseHandle(hToken);
+ CloseHandle(hToken);
}
return -1;
}
- /*
- * Clean up.
+
+ /*
+ * Clean up.
*/
+
HeapFree(GetProcessHeap (), 0, sdPtr);
CloseHandle(hToken);
if (!accessYesNo) {
@@ -1519,15 +1708,15 @@ NativeAccess(nativePath, mode)
*
* NativeIsExec --
*
- * Determines if a path is executable. On windows this is
- * simply defined by whether the path ends in any of ".exe",
- * ".com", or ".bat"
+ * Determines if a path is executable. On windows this is simply defined
+ * by whether the path ends in any of ".exe", ".com", or ".bat"
*
* Results:
* 1 = executable, 0 = not.
*
*----------------------------------------------------------------------
*/
+
static int
NativeIsExec(nativePath)
CONST TCHAR *nativePath;
@@ -1535,38 +1724,43 @@ NativeIsExec(nativePath)
if (tclWinProcs->useWide) {
CONST WCHAR *path;
int len;
-
+
path = (CONST WCHAR*)nativePath;
len = wcslen(path);
-
+
if (len < 5) {
return 0;
}
-
+
if (path[len-4] != L'.') {
return 0;
}
-
+
/*
* Use wide-char case-insensitive comparison
*/
+
if ((_wcsicmp(path+len-3,L"exe") == 0)
- || (_wcsicmp(path+len-3,L"com") == 0)
- || (_wcsicmp(path+len-3,L"bat") == 0)) {
+ || (_wcsicmp(path+len-3,L"com") == 0)
+ || (_wcsicmp(path+len-3,L"bat") == 0)) {
return 1;
}
} else {
CONST char *p;
-
- /* We are only looking for pure ascii */
-
+
+ /*
+ * We are only looking for pure ascii.
+ */
+
p = strrchr((CONST char*)nativePath, '.');
if (p != NULL) {
p++;
- /*
+
+ /*
* Note: in the old code, stat considered '.pif' files as
* executable, whereas access did not.
*/
+
if ((stricmp(p, "exe") == 0)
|| (stricmp(p, "com") == 0)
|| (stricmp(p, "bat") == 0)) {
@@ -1592,28 +1786,31 @@ NativeIsExec(nativePath)
* See chdir() documentation.
*
* Side effects:
- * See chdir() documentation.
+ * See chdir() documentation.
*
*----------------------------------------------------------------------
*/
-int
+int
TclpObjChdir(pathPtr)
- Tcl_Obj *pathPtr; /* Path to new working directory. */
+ Tcl_Obj *pathPtr; /* Path to new working directory. */
{
int result;
CONST TCHAR *nativePath;
#ifdef __CYGWIN__
- extern int cygwin_conv_to_posix_path
- _ANSI_ARGS_((CONST char *, char *));
+ extern int cygwin_conv_to_posix_path(CONST char *, char *);
char posixPath[MAX_PATH+1];
CONST char *path;
Tcl_DString ds;
#endif /* __CYGWIN__ */
nativePath = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr);
+
#ifdef __CYGWIN__
- /* Cygwin chdir only groks POSIX path. */
+ /*
+ * Cygwin chdir only groks POSIX path.
+ */
+
path = Tcl_WinTCharToUtf(nativePath, -1, &ds);
cygwin_conv_to_posix_path(path, posixPath);
result = (chdir(posixPath) == 0 ? 1 : 0);
@@ -1635,26 +1832,26 @@ TclpObjChdir(pathPtr)
*
* TclpReadlink --
*
- * This function replaces the library version of readlink().
+ * This function replaces the library version of readlink().
*
* Results:
- * The result is a pointer to a string specifying the contents
- * of the symbolic link given by 'path', or NULL if the symbolic
- * link could not be read. Storage for the result string is
- * allocated in bufferPtr; the caller must call Tcl_DStringFree()
- * when the result is no longer needed.
+ * The result is a pointer to a string specifying the contents of the
+ * symbolic link given by 'path', or NULL if the symbolic link could not
+ * be read. Storage for the result string is allocated in bufferPtr; the
+ * caller must call Tcl_DStringFree() when the result is no longer
+ * needed.
*
* Side effects:
- * See readlink() documentation.
+ * See readlink() documentation.
*
*---------------------------------------------------------------------------
*/
char *
TclpReadlink(path, linkPtr)
- CONST char *path; /* Path of file to readlink (UTF-8). */
- Tcl_DString *linkPtr; /* Uninitialized or free DString filled
- * with contents of link (UTF-8). */
+ CONST char *path; /* Path of file to readlink (UTF-8). */
+ Tcl_DString *linkPtr; /* Uninitialized or free DString filled with
+ * contents of link (UTF-8). */
{
char link[MAXPATHLEN];
int length;
@@ -1662,9 +1859,9 @@ TclpReadlink(path, linkPtr)
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
- length = readlink(native, link, sizeof(link)); /* INTL: Native. */
+ length = readlink(native, link, sizeof(link)); /* INTL: Native. */
Tcl_DStringFree(&ds);
-
+
if (length < 0) {
return NULL;
}
@@ -1679,17 +1876,16 @@ TclpReadlink(path, linkPtr)
*
* TclpGetCwd --
*
- * This function replaces the library version of getcwd().
- * (Obsolete function, only retained for old extensions which
- * may call it directly).
+ * This function replaces the library version of getcwd(). (Obsolete
+ * function, only retained for old extensions which may call it
+ * directly).
*
* Results:
- * The result is a pointer to a string specifying the current
- * directory, or NULL if the current directory could not be
- * determined. If NULL is returned, an error message is left in the
- * interp's result. Storage for the result string is allocated in
- * bufferPtr; the caller must call Tcl_DStringFree() when the result
- * is no longer needed.
+ * The result is a pointer to a string specifying the current directory,
+ * or NULL if the current directory could not be determined. If NULL is
+ * returned, an error message is left in the interp's result. Storage for
+ * the result string is allocated in bufferPtr; the caller must call
+ * Tcl_DStringFree() when the result is no longer needed.
*
* Side effects:
* None.
@@ -1700,8 +1896,8 @@ TclpReadlink(path, linkPtr)
CONST char *
TclpGetCwd(interp, bufferPtr)
Tcl_Interp *interp; /* If non-NULL, used for error reporting. */
- Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
- * with name of current directory. */
+ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with
+ * name of current directory. */
{
WCHAR buffer[MAX_PATH];
char *p;
@@ -1709,8 +1905,7 @@ TclpGetCwd(interp, bufferPtr)
if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
- Tcl_AppendResult(interp,
- "error getting working directory name: ",
+ Tcl_AppendResult(interp, "error getting working directory name: ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
@@ -1724,7 +1919,7 @@ TclpGetCwd(interp, bufferPtr)
WCHAR *native;
native = (WCHAR *) buffer;
- if ((native[0] != '\0') && (native[1] == ':')
+ if ((native[0] != '\0') && (native[1] == ':')
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
@@ -1733,7 +1928,7 @@ TclpGetCwd(interp, bufferPtr)
char *native;
native = (char *) buffer;
- if ((native[0] != '\0') && (native[1] == ':')
+ if ((native[0] != '\0') && (native[1] == ':')
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
@@ -1743,7 +1938,7 @@ TclpGetCwd(interp, bufferPtr)
/*
* Convert to forward slashes for easier use in scripts.
*/
-
+
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
@@ -1752,16 +1947,17 @@ TclpGetCwd(interp, bufferPtr)
return Tcl_DStringValue(bufferPtr);
}
-int
+int
TclpObjStat(pathPtr, statPtr)
- Tcl_Obj *pathPtr; /* Path of file to stat */
- Tcl_StatBuf *statPtr; /* Filled with results of stat call. */
+ Tcl_Obj *pathPtr; /* Path of file to stat. */
+ Tcl_StatBuf *statPtr; /* Filled with results of stat call. */
{
#ifdef OLD_API
Tcl_Obj *transPtr;
+
/*
- * Eliminate file names containing wildcard characters, or subsequent
- * call to FindFirstFile() will expand them, matching some other file.
+ * Eliminate file names containing wildcard characters, or subsequent call
+ * to FindFirstFile() will expand them, matching some other file.
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
@@ -1774,14 +1970,14 @@ TclpObjStat(pathPtr, statPtr)
}
Tcl_DecrRefCount(transPtr);
#endif
-
+
/*
- * Ensure correct file sizes by forcing the OS to write any
- * pending data to disk. This is done only for channels which are
- * dirty, i.e. have been written to since the last flush here.
+ * Ensure correct file sizes by forcing the OS to write any pending data
+ * to disk. This is done only for channels which are dirty, i.e. have been
+ * written to since the last flush here.
*/
- TclWinFlushDirtyChannels ();
+ TclWinFlushDirtyChannels();
return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}
@@ -1791,8 +1987,8 @@ TclpObjStat(pathPtr, statPtr)
*
* NativeStat --
*
- * This function replaces the library version of stat(), fixing
- * the following bugs:
+ * This function replaces the library version of stat(), fixing the
+ * following bugs:
*
* 1. stat("c:") returns an error.
* 2. Borland stat() return time in GMT instead of localtime.
@@ -1809,11 +2005,11 @@ TclpObjStat(pathPtr, statPtr)
*----------------------------------------------------------------------
*/
-static int
+static int
NativeStat(nativePath, statPtr, checkLinks)
- CONST TCHAR *nativePath; /* Path of file to stat */
- Tcl_StatBuf *statPtr; /* Filled with results of stat call. */
- int checkLinks; /* If non-zero, behave like 'lstat' */
+ CONST TCHAR *nativePath; /* Path of file to stat */
+ Tcl_StatBuf *statPtr; /* Filled with results of stat call. */
+ int checkLinks; /* If non-zero, behave like 'lstat' */
{
Tcl_DString ds;
DWORD attr;
@@ -1822,18 +2018,19 @@ NativeStat(nativePath, statPtr, checkLinks)
CONST char *fullPath;
int dev;
unsigned short mode;
-
+
if (tclWinProcs->getFileAttributesExProc == NULL) {
- /*
- * We don't have the faster attributes proc, so we're
- * probably running on Win95
- */
+ /*
+ * We don't have the faster attributes proc, so we're probably running
+ * on Win95.
+ */
+
WIN32_FIND_DATAT data;
HANDLE handle;
handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
if (handle == INVALID_HANDLE_VALUE) {
- /*
+ /*
* FindFirstFile() doesn't work on root directories, so call
* GetFileAttributes() to see if the specified file exists.
*/
@@ -1844,9 +2041,9 @@ NativeStat(nativePath, statPtr, checkLinks)
return -1;
}
- /*
- * Make up some fake information for this file. It has the
- * correct file attributes and a time of 0.
+ /*
+ * Make up some fake information for this file. It has the correct
+ * file attributes and a time of 0.
*/
memset(&data, 0, sizeof(data));
@@ -1855,9 +2052,8 @@ NativeStat(nativePath, statPtr, checkLinks)
FindClose(handle);
}
-
- (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
- &nativePart);
+ (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH,
+ nativeFullPath, &nativePart);
fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
@@ -1872,7 +2068,7 @@ NativeStat(nativePath, statPtr, checkLinks)
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
- * Add terminating backslash to fullpath or
+ * Add terminating backslash to fullpath or
* GetVolumeInformation() won't work.
*/
@@ -1885,12 +2081,13 @@ NativeStat(nativePath, statPtr, checkLinks)
dw = (DWORD) -1;
(*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
NULL, NULL, NULL, 0);
+
/*
* GetFullPathName() turns special devices like "NUL" into
* "\\.\NUL", but GetVolumeInformation() returns failure for
- * "\\.\NUL". This will cause "NUL" to get a drive number of
- * -1, which makes about as much sense as anything since the
- * special devices don't live on any drive.
+ * "\\.\NUL". This will cause "NUL" to get a drive number of -1,
+ * which makes about as much sense as anything since the special
+ * devices don't live on any drive.
*/
dev = dw;
@@ -1899,26 +2096,25 @@ NativeStat(nativePath, statPtr, checkLinks)
dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
}
Tcl_DStringFree(&ds);
-
+
attr = data.a.dwFileAttributes;
- statPtr->st_size = ((Tcl_WideInt)data.a.nFileSizeLow) |
+ statPtr->st_size = ((Tcl_WideInt)data.a.nFileSizeLow) |
(((Tcl_WideInt)data.a.nFileSizeHigh) << 32);
statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
} else {
WIN32_FILE_ATTRIBUTE_DATA data;
- if((*tclWinProcs->getFileAttributesExProc)(nativePath,
- GetFileExInfoStandard,
- &data) != TRUE) {
+
+ if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
+ GetFileExInfoStandard, &data) != TRUE) {
Tcl_SetErrno(ENOENT);
return -1;
}
-
- (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH,
- nativeFullPath, &nativePart);
+ (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH,
+ nativeFullPath, &nativePart);
fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
@@ -1933,7 +2129,7 @@ NativeStat(nativePath, statPtr, checkLinks)
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
- * Add terminating backslash to fullpath or
+ * Add terminating backslash to fullpath or
* GetVolumeInformation() won't work.
*/
@@ -1946,12 +2142,13 @@ NativeStat(nativePath, statPtr, checkLinks)
dw = (DWORD) -1;
(*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
NULL, NULL, NULL, 0);
+
/*
* GetFullPathName() turns special devices like "NUL" into
* "\\.\NUL", but GetVolumeInformation() returns failure for
- * "\\.\NUL". This will cause "NUL" to get a drive number of
- * -1, which makes about as much sense as anything since the
- * special devices don't live on any drive.
+ * "\\.\NUL". This will cause "NUL" to get a drive number of -1,
+ * which makes about as much sense as anything since the special
+ * devices don't live on any drive.
*/
dev = dw;
@@ -1960,10 +2157,10 @@ NativeStat(nativePath, statPtr, checkLinks)
dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
}
Tcl_DStringFree(&ds);
-
+
attr = data.dwFileAttributes;
-
- statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) |
+
+ statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) |
(((Tcl_WideInt)data.nFileSizeHigh) << 32);
statPtr->st_atime = ToCTime(data.ftLastAccessTime);
statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
@@ -1971,7 +2168,7 @@ NativeStat(nativePath, statPtr, checkLinks)
}
mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath));
-
+
statPtr->st_dev = (dev_t) dev;
statPtr->st_ino = 0;
statPtr->st_mode = mode;
@@ -1988,31 +2185,33 @@ NativeStat(nativePath, statPtr, checkLinks)
* NativeStatMode --
*
* Calculate just the 'st_mode' field of a 'stat' structure.
- *
- * In many places we don't need the full stat structure, and
- * it's much faster just to calculate these pieces, if that's
- * all we need.
+ *
+ * In many places we don't need the full stat structure, and it's much
+ * faster just to calculate these pieces, if that's all we need.
*
*----------------------------------------------------------------------
*/
+
static unsigned short
-NativeStatMode(DWORD attr, int checkLinks, int isExec)
+NativeStatMode(DWORD attr, int checkLinks, int isExec)
{
int mode;
if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
- /* It is a link */
+ /*
+ * It is a link.
+ */
mode = S_IFLNK;
} else {
- mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
+ mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
}
mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
if (isExec) {
mode |= S_IEXEC;
}
-
+
/*
- * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
- * other positions.
+ * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and other
+ * positions.
*/
mode |= (mode & 0x0700) >> 3;
@@ -2037,13 +2236,13 @@ static time_t
ToCTime(FILETIME fileTime) /* UTC time */
{
LARGE_INTEGER convertedTime;
+
convertedTime.LowPart = fileTime.dwLowDateTime;
convertedTime.HighPart = (LONG) fileTime.dwHighDateTime;
+
return (time_t) ((convertedTime.QuadPart
- - (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME)
- / (Tcl_WideInt) 10000000);
+ - (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME) / (Tcl_WideInt) 10000000);
}
-
/*
*------------------------------------------------------------------------
@@ -2059,54 +2258,55 @@ ToCTime(FILETIME fileTime) /* UTC time */
*/
static void
-FromCTime(time_t posixTime,
- FILETIME* fileTime) /* UTC Time */
+FromCTime(
+ time_t posixTime,
+ FILETIME* fileTime) /* UTC Time */
{
LARGE_INTEGER convertedTime;
- convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000
+ convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000
+ POSIX_EPOCH_AS_FILETIME;
fileTime->dwLowDateTime = convertedTime.LowPart;
fileTime->dwHighDateTime = convertedTime.HighPart;
}
-
+
#if 0
/*
*-------------------------------------------------------------------------
*
* TclWinResolveShortcut --
*
- * Resolve a potential Windows shortcut to get the actual file or
- * directory in question.
+ * Resolve a potential Windows shortcut to get the actual file or
+ * directory in question.
*
* Results:
- * Returns 1 if the shortcut could be resolved, or 0 if there was
- * an error or if the filename was not a shortcut.
- * If bufferPtr did hold the name of a shortcut, it is modified to
- * hold the resolved target of the shortcut instead.
+ * Returns 1 if the shortcut could be resolved, or 0 if there was an
+ * error or if the filename was not a shortcut. If bufferPtr did hold the
+ * name of a shortcut, it is modified to hold the resolved target of the
+ * shortcut instead.
*
* Side effects:
- * Loads and unloads OLE package to determine if filename refers to
- * a shortcut.
+ * Loads and unloads OLE package to determine if filename refers to a
+ * shortcut.
*
*-------------------------------------------------------------------------
*/
int
TclWinResolveShortcut(bufferPtr)
- Tcl_DString *bufferPtr; /* Holds name of file to resolve. On
- * return, holds resolved file name. */
+ Tcl_DString *bufferPtr; /* Holds name of file to resolve. On return,
+ * holds resolved file name. */
{
- HRESULT hres;
- IShellLink *psl;
- IPersistFile *ppf;
- WIN32_FIND_DATA wfd;
+ HRESULT hres;
+ IShellLink *psl;
+ IPersistFile *ppf;
+ WIN32_FIND_DATA wfd;
WCHAR wpath[MAX_PATH];
char *path, *ext;
char realFileName[MAX_PATH];
/*
- * Windows system calls do not automatically resolve
- * shortcuts like UNIX automatically will with symbolic links.
+ * Windows system calls do not automatically resolve shortcuts like UNIX
+ * automatically will with symbolic links.
*/
path = Tcl_DStringValue(bufferPtr);
@@ -2118,25 +2318,24 @@ TclWinResolveShortcut(bufferPtr)
CoInitialize(NULL);
path = Tcl_DStringValue(bufferPtr);
realFileName[0] = '\0';
- hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER,
- &IID_IShellLink, &psl);
- if (SUCCEEDED(hres)) {
+ hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER,
+ &IID_IShellLink, &psl);
+ if (SUCCEEDED(hres)) {
hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
- if (SUCCEEDED(hres)) {
+ if (SUCCEEDED(hres)) {
MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
- hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ);
+ hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ);
if (SUCCEEDED(hres)) {
- hres = psl->lpVtbl->Resolve(psl, NULL,
- SLR_ANY_MATCH | SLR_NO_UI);
- if (SUCCEEDED(hres)) {
- hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH,
+ hres = psl->lpVtbl->Resolve(psl,NULL,SLR_ANY_MATCH|SLR_NO_UI);
+ if (SUCCEEDED(hres)) {
+ hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH,
&wfd, 0);
- }
- }
- ppf->lpVtbl->Release(ppf);
- }
- psl->lpVtbl->Release(psl);
- }
+ }
+ }
+ ppf->lpVtbl->Release(ppf);
+ }
+ psl->lpVtbl->Release(psl);
+ }
CoUninitialize();
if (realFileName[0] != '\0') {
@@ -2156,13 +2355,12 @@ TclWinResolveShortcut(bufferPtr)
* This function replaces the library version of getcwd().
*
* Results:
- * The input and output are filesystem paths in native form. The
- * result is either the given clientData, if the working directory
- * hasn't changed, or a new clientData (owned by our caller),
- * giving the new native path, or NULL if the current directory
- * could not be determined. If NULL is returned, the caller can
- * examine the standard posix error codes to determine the cause of
- * the problem.
+ * The input and output are filesystem paths in native form. The result
+ * is either the given clientData, if the working directory hasn't
+ * changed, or a new clientData (owned by our caller), giving the new
+ * native path, or NULL if the current directory could not be determined.
+ * If NULL is returned, the caller can examine the standard posix error
+ * codes to determine the cause of the problem.
*
* Side effects:
* None.
@@ -2175,58 +2373,61 @@ TclpGetNativeCwd(clientData)
ClientData clientData;
{
WCHAR buffer[MAX_PATH];
-
+
if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
return NULL;
}
if (clientData != NULL) {
- if (tclWinProcs->useWide) {
- /* unicode representation when running on NT/2K/XP */
- if (wcscmp((CONST WCHAR*)clientData,
- (CONST WCHAR*)buffer) == 0) {
+ if (tclWinProcs->useWide) {
+ /*
+ * Unicode representation when running on NT/2K/XP.
+ */
+
+ if (wcscmp((CONST WCHAR*)clientData, (CONST WCHAR*)buffer) == 0) {
return clientData;
}
} else {
- /* ansi representation when running on 95/98/ME */
- if (strcmp((CONST char*)clientData,
- (CONST char*)buffer) == 0) {
+ /*
+ * ANSI representation when running on 95/98/ME.
+ */
+
+ if (strcmp((CONST char*)clientData, (CONST char*)buffer) == 0) {
return clientData;
}
}
}
-
+
return TclNativeDupInternalRep((ClientData)buffer);
}
-
-int
+
+int
TclpObjAccess(pathPtr, mode)
Tcl_Obj *pathPtr;
int mode;
{
- return NativeAccess((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), mode);
+ return NativeAccess((CONST TCHAR *) Tcl_FSGetNativePath(pathPtr), mode);
}
-
-int
+
+int
TclpObjLstat(pathPtr, statPtr)
Tcl_Obj *pathPtr;
- Tcl_StatBuf *statPtr;
+ Tcl_StatBuf *statPtr;
{
/*
- * Ensure correct file sizes by forcing the OS to write any
- * pending data to disk. This is done only for channels which are
- * dirty, i.e. have been written to since the last flush here.
+ * Ensure correct file sizes by forcing the OS to write any pending data
+ * to disk. This is done only for channels which are dirty, i.e. have been
+ * written to since the last flush here.
*/
TclWinFlushDirtyChannels ();
return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}
-
+
#ifdef S_IFLNK
-
-Tcl_Obj*
+Tcl_Obj*
TclpObjLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr;
Tcl_Obj *toPtr;
@@ -2235,11 +2436,13 @@ TclpObjLink(pathPtr, toPtr, linkAction)
if (toPtr != NULL) {
int res;
#if 0
- TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(toPtr);
+ TCHAR *LinkTarget = (TCHAR *) Tcl_FSGetNativePath(toPtr);
#else
- TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(Tcl_FSGetNormalizedPath(NULL,toPtr));
+ TCHAR *LinkTarget = (TCHAR *) Tcl_FSGetNativePath(
+ Tcl_FSGetNormalizedPath(NULL, toPtr));
#endif
- TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
+ TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr);
+
if (LinkSource == NULL || LinkTarget == NULL) {
return NULL;
}
@@ -2250,34 +2453,34 @@ TclpObjLink(pathPtr, toPtr, linkAction)
return NULL;
}
} else {
- TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
+ TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr);
+
if (LinkSource == NULL) {
return NULL;
}
return WinReadLink(LinkSource);
}
}
-
#endif
-
/*
*---------------------------------------------------------------------------
*
* TclpFilesystemPathType --
*
- * This function is part of the native filesystem support, and
- * returns the path type of the given path. Returns NTFS or FAT
- * or whatever is returned by the 'volume information' proc.
+ * This function is part of the native filesystem support, and returns
+ * the path type of the given path. Returns NTFS or FAT or whatever is
+ * returned by the 'volume information' proc.
*
* Results:
- * NULL at present.
+ * NULL at present.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
+
Tcl_Obj*
TclpFilesystemPathType(pathPtr)
Tcl_Obj* pathPtr;
@@ -2287,23 +2490,28 @@ TclpFilesystemPathType(pathPtr)
WCHAR volType[VOL_BUF_SIZE];
char* firstSeparator;
CONST char *path;
-
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
- if (normPath == NULL) return NULL;
+
+ if (normPath == NULL) {
+ return NULL;
+ }
path = Tcl_GetString(normPath);
- if (path == NULL) return NULL;
-
+ if (path == NULL) {
+ return NULL;
+ }
+
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
found = tclWinProcs->getVolumeInformationProc(
- Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL,
- NULL, (WCHAR *)volType, VOL_BUF_SIZE);
+ Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL,
+ (WCHAR *) volType, VOL_BUF_SIZE);
} else {
Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);
+
Tcl_IncrRefCount(driveName);
found = tclWinProcs->getVolumeInformationProc(
- Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL,
- NULL, (WCHAR *)volType, VOL_BUF_SIZE);
+ Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL,
+ (WCHAR *) volType, VOL_BUF_SIZE);
Tcl_DecrRefCount(driveName);
}
@@ -2312,27 +2520,29 @@ TclpFilesystemPathType(pathPtr)
} else {
Tcl_DString ds;
Tcl_Obj *objPtr;
-
+
Tcl_WinTCharToUtf((CONST char *)volType, -1, &ds);
- objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
+ objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
return objPtr;
}
#undef VOL_BUF_SIZE
}
-/*
+
+/*
* This define can be turned on to experiment with a different way of
- * normalizing paths (using a different Windows API). Unfortunately the
- * new path seems to take almost exactly the same amount of time as the
- * old path! The primary time taken by normalization is in
- * GetFileAttributesEx/FindFirstFile or
- * GetFileAttributesEx/GetLongPathName. Conversion to/from native is
- * not a significant factor at all.
- *
- * Also, since we have to check for symbolic links (reparse points)
- * then we have to call GetFileAttributes on each path segment anyway,
- * so there's no benefit to doing anything clever there.
+ * normalizing paths (using a different Windows API). Unfortunately the new
+ * path seems to take almost exactly the same amount of time as the old path!
+ * The primary time taken by normalization is in
+ * GetFileAttributesEx/FindFirstFile or GetFileAttributesEx/GetLongPathName.
+ * Conversion to/from native is not a significant factor at all.
+ *
+ * Also, since we have to check for symbolic links (reparse points) then we
+ * have to call GetFileAttributes on each path segment anyway, so there's no
+ * benefit to doing anything clever there.
*/
+
/* #define TclNORM_LONG_PATH */
/*
@@ -2340,18 +2550,17 @@ TclpFilesystemPathType(pathPtr)
*
* TclpObjNormalizePath --
*
- * This function scans through a path specification and replaces it,
- * in place, with a normalized version. This means using the
- * 'longname', and expanding any symbolic links contained within the
- * path.
+ * This function scans through a path specification and replaces it, in
+ * place, with a normalized version. This means using the 'longname', and
+ * expanding any symbolic links contained within the path.
*
* Results:
- * The new 'nextCheckpoint' value, giving as far as we could
- * understand in the path.
+ * The new 'nextCheckpoint' value, giving as far as we could understand
+ * in the path.
*
* Side effects:
- * The pathPtr string, which must contain a valid path, is
- * possibly modified in place.
+ * The pathPtr string, which must contain a valid path, is possibly
+ * modified in place.
*
*---------------------------------------------------------------------------
*/
@@ -2362,8 +2571,7 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
int nextCheckpoint;
{
char *lastValidPathEnd = NULL;
- /* This will hold the normalized string */
- Tcl_DString dsNorm;
+ Tcl_DString dsNorm; /* This will hold the normalized string. */
char *path;
char *currentPathEndPosition;
@@ -2371,40 +2579,52 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
path = Tcl_GetString(pathPtr);
if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
- /*
- * We're on Win95, 98 or ME. There are two assumptions
- * in this block of code. First that the native (NULL)
- * encoding is basically ascii, and second that symbolic
- * links are not possible. Both of these assumptions
- * appear to be true of these operating systems.
+ /*
+ * We're on Win95, 98 or ME. There are two assumptions in this block
+ * of code. First that the native (NULL) encoding is basically ascii,
+ * and second that symbolic links are not possible. Both of these
+ * assumptions appear to be true of these operating systems.
*/
+
int isDrive = 1;
Tcl_DString ds;
currentPathEndPosition = path + nextCheckpoint;
- if (*currentPathEndPosition == '/') {
+ if (*currentPathEndPosition == '/') {
currentPathEndPosition++;
- }
+ }
+
while (1) {
char cur = *currentPathEndPosition;
if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
- /* Reached directory separator, or end of string */
- CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path,
- currentPathEndPosition - path, &ds);
+ /*
+ * Reached directory separator, or end of string.
+ */
+
+ CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path,
+ currentPathEndPosition - path, &ds);
/*
- * Now we convert the tail of the current path to its
- * 'long form', and append it to 'dsNorm' which holds
- * the current normalized path, if the file exists.
+ * Now we convert the tail of the current path to its 'long
+ * form', and append it to 'dsNorm' which holds the current
+ * normalized path, if the file exists.
*/
+
if (isDrive) {
if (GetFileAttributesA(nativePath) == 0xffffffff) {
- /* File doesn't exist */
+ /*
+ * File doesn't exist.
+ */
+
if (isDrive) {
int len = WinIsReserved(path);
if (len > 0) {
- /* Actually it does exist - COM1, etc */
+ /*
+ * Actually it does exist - COM1, etc.
+ */
+
int i;
+
for (i=0;i<len;i++) {
if (nativePath[i] >= 'a') {
((char*)nativePath)[i] -= ('a' - 'A');
@@ -2420,10 +2640,11 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
if (nativePath[0] >= 'a') {
((char*)nativePath)[0] -= ('a' - 'A');
}
- Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
+ Tcl_DStringAppend(&dsNorm, nativePath,
+ Tcl_DStringLength(&ds));
} else {
char *checkDots = NULL;
-
+
if (lastValidPathEnd[1] == '.') {
checkDots = lastValidPathEnd + 1;
while (checkDots < currentPathEndPosition) {
@@ -2436,33 +2657,45 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
}
if (checkDots != NULL) {
int dotLen = currentPathEndPosition - lastValidPathEnd;
- /*
- * Path is just dots. We shouldn't really
- * ever see a path like that. However, to be
- * nice we at least don't mangle the path --
- * we just add the dots as a path segment and
- * continue
+
+ /*
+ * Path is just dots. We shouldn't really ever see a
+ * path like that. However, to be nice we at least
+ * don't mangle the path - we just add the dots as a
+ * path segment and continue
*/
- Tcl_DStringAppend(&dsNorm, (TCHAR*)(nativePath
- + Tcl_DStringLength(&ds)
- - dotLen), dotLen);
+
+ Tcl_DStringAppend(&dsNorm, (TCHAR *)
+ (nativePath + Tcl_DStringLength(&ds) - dotLen),
+ dotLen);
} else {
- /* Normal path */
+ /*
+ * Normal path.
+ */
+
WIN32_FIND_DATA fData;
HANDLE handle;
-
+
handle = FindFirstFileA(nativePath, &fData);
if (handle == INVALID_HANDLE_VALUE) {
- if (GetFileAttributesA(nativePath)
- == 0xffffffff) {
- /* File doesn't exist */
+ if (GetFileAttributesA(nativePath) == 0xffffffff) {
+ /*
+ * File doesn't exist.
+ */
+
Tcl_DStringFree(&ds);
break;
}
- /* This is usually the '/' in 'c:/' at end of string */
+
+ /*
+ * This is usually the '/' in 'c:/' at end of
+ * string.
+ */
+
Tcl_DStringAppend(&dsNorm,"/", 1);
} else {
char *nativeName;
+
if (fData.cFileName[0] != '\0') {
nativeName = fData.cFileName;
} else {
@@ -2479,20 +2712,23 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
if (cur == 0) {
break;
}
- /*
- * If we get here, we've got past one directory
- * delimiter, so we know it is no longer a drive
+ /*
+ * If we get here, we've got past one directory delimiter, so
+ * we know it is no longer a drive.
*/
isDrive = 0;
}
currentPathEndPosition++;
}
} else {
- /* We're on WinNT or 2000 or XP */
+ /*
+ * We're on WinNT (or 2000 or XP; something with an NT core).
+ */
+
Tcl_Obj *temp = NULL;
int isDrive = 1;
Tcl_DString ds;
-
+
currentPathEndPosition = path + nextCheckpoint;
if (*currentPathEndPosition == '/') {
currentPathEndPosition++;
@@ -2500,27 +2736,39 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
while (1) {
char cur = *currentPathEndPosition;
if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
- /* Reached directory separator, or end of string */
+ /*
+ * Reached directory separator, or end of string.
+ */
+
WIN32_FILE_ATTRIBUTE_DATA data;
- CONST char *nativePath = Tcl_WinUtfToTChar(path,
- currentPathEndPosition - path, &ds);
+ CONST char *nativePath = Tcl_WinUtfToTChar(path,
+ currentPathEndPosition - path, &ds);
+
if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
- GetFileExInfoStandard, &data) != TRUE) {
- /* File doesn't exist */
+ GetFileExInfoStandard, &data) != TRUE) {
+ /*
+ * File doesn't exist.
+ */
+
if (isDrive) {
- int len = WinIsReserved(path);
+ int len = WinIsReserved(path);
+
if (len > 0) {
- /* Actually it does exist - COM1, etc */
+ /*
+ * Actually it does exist - COM1, etc.
+ */
+
int i;
+
for (i=0;i<len;i++) {
- WCHAR wc = ((WCHAR*)nativePath)[i];
+ WCHAR wc = ((WCHAR*)nativePath)[i];
if (wc >= L'a') {
wc -= (L'a' - L'A');
((WCHAR*)nativePath)[i] = wc;
}
}
Tcl_DStringAppend(&dsNorm, nativePath,
- sizeof(WCHAR)*len);
+ sizeof(WCHAR)*len);
lastValidPathEnd = currentPathEndPosition;
}
}
@@ -2528,38 +2776,42 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
break;
}
- /*
- * File 'nativePath' does exist if we get here. We
- * now want to check if it is a symlink and otherwise
- * continue with the rest of the path.
+ /*
+ * File 'nativePath' does exist if we get here. We now want to
+ * check if it is a symlink and otherwise continue with the
+ * rest of the path.
*/
-
- /*
- * Check for symlinks, except at last component
- * of path (we don't follow final symlinks). Also
- * a drive (C:/) for example, may sometimes have
- * the reparse flag set for some reason I don't
- * understand. We therefore don't perform this
+
+ /*
+ * Check for symlinks, except at last component of path (we
+ * don't follow final symlinks). Also a drive (C:/) for
+ * example, may sometimes have the reparse flag set for some
+ * reason I don't understand. We therefore don't perform this
* check for drives.
*/
- if (cur != 0 && !isDrive
- && (data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT)) {
+
+ if (cur != 0 && !isDrive &&
+ (data.dwFileAttributes&FILE_ATTRIBUTE_REPARSE_POINT)) {
Tcl_Obj *to = WinReadLinkDirectory(nativePath);
+
if (to != NULL) {
- /*
- * Read the reparse point ok. Now, reparse
- * points need not be normalized, otherwise
- * we could use:
- *
- * Tcl_GetStringFromObj(to, &pathLen);
+ /*
+ * Read the reparse point ok. Now, reparse points need
+ * not be normalized, otherwise we could use:
+ *
+ * Tcl_GetStringFromObj(to, &pathLen);
* nextCheckpoint = pathLen
- *
- * So, instead we have to start from the
- * beginning.
+ *
+ * So, instead we have to start from the beginning.
*/
+
nextCheckpoint = 0;
Tcl_AppendToObj(to, currentPathEndPosition, -1);
- /* Convert link to forward slashes */
+
+ /*
+ * Convert link to forward slashes.
+ */
+
for (path = Tcl_GetString(to); *path != 0; path++) {
if (*path == '\\') *path = '/';
}
@@ -2569,7 +2821,11 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
Tcl_DecrRefCount(temp);
}
temp = to;
- /* Reset variables so we can restart normalization */
+
+ /*
+ * Reset variables so we can restart normalization.
+ */
+
isDrive = 1;
Tcl_DStringFree(&dsNorm);
Tcl_DStringInit(&dsNorm);
@@ -2577,22 +2833,25 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
continue;
}
}
+
#ifndef TclNORM_LONG_PATH
/*
- * Now we convert the tail of the current path to its
- * 'long form', and append it to 'dsNorm' which holds
- * the current normalized path
+ * Now we convert the tail of the current path to its 'long
+ * form', and append it to 'dsNorm' which holds the current
+ * normalized path
*/
+
if (isDrive) {
WCHAR drive = ((WCHAR*)nativePath)[0];
if (drive >= L'a') {
- drive -= (L'a' - L'A');
+ drive -= (L'a' - L'A');
((WCHAR*)nativePath)[0] = drive;
}
- Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
+ Tcl_DStringAppend(&dsNorm, nativePath,
+ Tcl_DStringLength(&ds));
} else {
char *checkDots = NULL;
-
+
if (lastValidPathEnd[1] == '.') {
checkDots = lastValidPathEnd + 1;
while (checkDots < currentPathEndPosition) {
@@ -2605,40 +2864,47 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
}
if (checkDots != NULL) {
int dotLen = currentPathEndPosition - lastValidPathEnd;
- /*
- * Path is just dots. We shouldn't really
- * ever see a path like that. However, to be
- * nice we at least don't mangle the path --
- * we just add the dots as a path segment and
- * continue
+
+ /*
+ * Path is just dots. We shouldn't really ever see a
+ * path like that. However, to be nice we at least
+ * don't mangle the path - we just add the dots as a
+ * path segment and continue.
*/
- Tcl_DStringAppend(&dsNorm,
- (TCHAR*)((WCHAR*)(nativePath
- + Tcl_DStringLength(&ds))
- - dotLen),
- (int)(dotLen * sizeof(WCHAR)));
+
+ Tcl_DStringAppend(&dsNorm, (TCHAR *)
+ ((WCHAR*)(nativePath + Tcl_DStringLength(&ds))
+ - dotLen), (int)(dotLen * sizeof(WCHAR)));
} else {
- /* Normal path */
+ /*
+ * Normal path.
+ */
+
WIN32_FIND_DATAW fData;
HANDLE handle;
handle = FindFirstFileW((WCHAR*)nativePath, &fData);
if (handle == INVALID_HANDLE_VALUE) {
- /* This is usually the '/' in 'c:/' at end of string */
- Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
- sizeof(WCHAR));
+ /*
+ * This is usually the '/' in 'c:/' at end of
+ * string.
+ */
+
+ Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
+ sizeof(WCHAR));
} else {
WCHAR *nativeName;
+
if (fData.cFileName[0] != '\0') {
nativeName = fData.cFileName;
} else {
nativeName = fData.cAlternateFileName;
}
FindClose(handle);
- Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
- sizeof(WCHAR));
- Tcl_DStringAppend(&dsNorm,(TCHAR*)nativeName,
- (int) (wcslen(nativeName)*sizeof(WCHAR)));
+ Tcl_DStringAppend(&dsNorm, (CONST char*)L"/",
+ sizeof(WCHAR));
+ Tcl_DStringAppend(&dsNorm, (TCHAR *) nativeName,
+ (int) (wcslen(nativeName)*sizeof(WCHAR)));
}
}
}
@@ -2648,27 +2914,33 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
if (cur == 0) {
break;
}
- /*
- * If we get here, we've got past one directory
- * delimiter, so we know it is no longer a drive
+
+ /*
+ * If we get here, we've got past one directory delimiter, so
+ * we know it is no longer a drive.
*/
+
isDrive = 0;
}
currentPathEndPosition++;
}
+
#ifdef TclNORM_LONG_PATH
- /*
+ /*
* Convert the entire known path to long form.
*/
+
if (1) {
WCHAR wpath[MAX_PATH];
- DWORD wpathlen;
- CONST char *nativePath = Tcl_WinUtfToTChar(path,
- lastValidPathEnd - path, &ds);
- wpathlen = (*tclWinProcs->getLongPathNameProc)(nativePath,
- (TCHAR*)wpath,
- MAX_PATH);
- /* We have to make the drive letter uppercase */
+ CONST char *nativePath =
+ Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds);
+ DWORD wpathlen = (*tclWinProcs->getLongPathNameProc)(
+ nativePath, (TCHAR *) wpath, MAX_PATH);
+
+ /*
+ * We have to make the drive letter uppercase.
+ */
+
if (wpath[0] >= L'a') {
wpath[0] -= (L'a' - L'A');
}
@@ -2677,34 +2949,46 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
}
#endif
}
- /* Common code path for all Windows platforms */
+
+ /*
+ * Common code path for all Windows platforms.
+ */
+
nextCheckpoint = currentPathEndPosition - path;
if (lastValidPathEnd != NULL) {
- /*
- * Concatenate the normalized string in dsNorm with the
- * tail of the path which we didn't recognise. The
- * string in dsNorm is in the native encoding, so we
- * have to convert it to Utf.
+ /*
+ * Concatenate the normalized string in dsNorm with the tail of the
+ * path which we didn't recognise. The string in dsNorm is in the
+ * native encoding, so we have to convert it to Utf.
*/
+
Tcl_DString dsTemp;
- Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm),
- Tcl_DStringLength(&dsNorm), &dsTemp);
+
+ Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm),
+ Tcl_DStringLength(&dsNorm), &dsTemp);
nextCheckpoint = Tcl_DStringLength(&dsTemp);
if (*lastValidPathEnd != 0) {
- /* Not the end of the string */
+ /*
+ * Not the end of the string.
+ */
+
int len;
char *path;
Tcl_Obj *tmpPathPtr;
- tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
- nextCheckpoint);
+
+ tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
+ nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
path = Tcl_GetStringFromObj(tmpPathPtr, &len);
Tcl_SetStringObj(pathPtr, path, len);
Tcl_DecrRefCount(tmpPathPtr);
} else {
- /* End of string was reached above */
+ /*
+ * End of string was reached above.
+ */
+
Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
- nextCheckpoint);
+ nextCheckpoint);
}
Tcl_DStringFree(&dsTemp);
}
@@ -2717,24 +3001,25 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
*
* TclWinVolumeRelativeNormalize --
*
- * Only Windows has volume-relative paths. These paths are rather
- * rare, but it is nice if Tcl can handle them. It is much better
- * if we can handle them here, rather than in the native fs code,
- * because we really need to have a real absolute path just below.
- *
- * We do not let this block compile on non-Windows platforms
- * because the test suite's manual forcing of tclPlatform can
- * otherwise cause this code path to be executed, causing various
- * errors because volume-relative paths really do not exist.
+ * Only Windows has volume-relative paths. These paths are rather rare,
+ * but it is nice if Tcl can handle them. It is much better if we can
+ * handle them here, rather than in the native fs code, because we really
+ * need to have a real absolute path just below.
+ *
+ * We do not let this block compile on non-Windows platforms because the
+ * test suite's manual forcing of tclPlatform can otherwise cause this
+ * code path to be executed, causing various errors because
+ * volume-relative paths really do not exist.
*
* Results:
- * A valid normalized path.
+ * A valid normalized path.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
+
Tcl_Obj*
TclWinVolumeRelativeNormalize(interp, path, useThisCwdPtr)
Tcl_Interp *interp;
@@ -2742,69 +3027,71 @@ TclWinVolumeRelativeNormalize(interp, path, useThisCwdPtr)
Tcl_Obj **useThisCwdPtr;
{
Tcl_Obj *absolutePath, *useThisCwd;
-
+
useThisCwd = Tcl_FSGetCwd(interp);
if (useThisCwd == NULL) {
- return NULL;
+ return NULL;
}
-
+
if (path[0] == '/') {
- /*
- * Path of form /foo/bar which is a path in the
- * root directory of the current volume.
+ /*
+ * Path of form /foo/bar which is a path in the root directory of the
+ * current volume.
*/
+
CONST char *drive = Tcl_GetString(useThisCwd);
-
+
absolutePath = Tcl_NewStringObj(drive,2);
Tcl_AppendToObj(absolutePath, path, -1);
Tcl_IncrRefCount(absolutePath);
- /* We have a refCount on the cwd */
+
+ /*
+ * We have a refCount on the cwd.
+ */
} else {
- /*
- * Path of form C:foo/bar, but this only makes
- * sense if the cwd is also on drive C.
+ /*
+ * Path of form C:foo/bar, but this only makes sense if the cwd is
+ * also on drive C.
*/
-
+
int cwdLen;
- CONST char *drive =
- Tcl_GetStringFromObj(useThisCwd, &cwdLen);
+ CONST char *drive =
+ Tcl_GetStringFromObj(useThisCwd, &cwdLen);
char drive_cur = path[0];
-
+
if (drive_cur >= 'a') {
drive_cur -= ('a' - 'A');
}
if (drive[0] == drive_cur) {
absolutePath = Tcl_DuplicateObj(useThisCwd);
- /*
- * We have a refCount on the cwd, which we
- * will release later.
+
+ /*
+ * We have a refCount on the cwd, which we will release later.
*/
if (drive[cwdLen-1] != '/' && (path[2] != '\0')) {
- /*
- * Only add a trailing '/' if needed, which
- * is if there isn't one already, and if we
- * are going to be adding some more
+ /*
+ * Only add a trailing '/' if needed, which is if there isn't
+ * one already, and if we are going to be adding some more
* characters.
*/
+
Tcl_AppendToObj(absolutePath, "/", 1);
}
} else {
Tcl_DecrRefCount(useThisCwd);
useThisCwd = NULL;
- /*
- * The path is not in the current drive, but
- * is volume-relative. The way Tcl 8.3 handles
- * this is that it treats such a path as
- * relative to the root of the drive. We
- * therefore behave the same here. This
- * behaviour is, however, different to that
- * of the windows command-line. If we want
- * to fix this at some point in the future
- * (at the expense of a behaviour change to
- * Tcl), we could use the '_dgetdcwd' Win32
- * API to get the drive's cwd.
+
+ /*
+ * The path is not in the current drive, but is volume-relative.
+ * The way Tcl 8.3 handles this is that it treats such a path as
+ * relative to the root of the drive. We therefore behave the same
+ * here. This behaviour is, however, different to that of the
+ * windows command-line. If we want to fix this at some point in
+ * the future (at the expense of a behaviour change to Tcl), we
+ * could use the '_dgetdcwd' Win32 API to get the drive's cwd.
*/
+
absolutePath = Tcl_NewStringObj(path, 2);
Tcl_AppendToObj(absolutePath, "/", 1);
}
@@ -2820,42 +3107,43 @@ TclWinVolumeRelativeNormalize(interp, path, useThisCwdPtr)
*
* TclpNativeToNormalized --
*
- * Convert native format to a normalized path object, with refCount
- * of zero.
- *
- * Currently assumes all native paths are actually normalized
- * already, so if the path given is not normalized this will
- * actually just convert to a valid string path, but not
- * necessarily a normalized one.
+ * Convert native format to a normalized path object, with refCount of
+ * zero.
+ *
+ * Currently assumes all native paths are actually normalized already, so
+ * if the path given is not normalized this will actually just convert to
+ * a valid string path, but not necessarily a normalized one.
*
* Results:
- * A valid normalized path.
+ * A valid normalized path.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
-Tcl_Obj*
+
+Tcl_Obj*
TclpNativeToNormalized(clientData)
ClientData clientData;
{
Tcl_DString ds;
Tcl_Obj *objPtr;
int len;
-
+
char *copy;
char *p;
Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
-
+
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
- /*
- * Certain native path representations on Windows have this special
- * prefix to indicate that they are to be treated specially. For
- * example extremely long paths, or symlinks
+ /*
+ * Certain native path representations on Windows have this special prefix
+ * to indicate that they are to be treated specially. For example
+ * extremely long paths, or symlinks.
*/
+
if (*copy == '\\') {
if (0 == strncmp(copy,"\\??\\",4)) {
copy += 4;
@@ -2865,9 +3153,11 @@ TclpNativeToNormalized(clientData)
len -= 4;
}
}
- /*
+
+ /*
* Ensure we are using forward slashes only.
*/
+
for (p = copy; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
@@ -2876,7 +3166,7 @@ TclpNativeToNormalized(clientData)
objPtr = Tcl_NewStringObj(copy,len);
Tcl_DStringFree(&ds);
-
+
return objPtr;
}
@@ -2885,17 +3175,18 @@ TclpNativeToNormalized(clientData)
*
* TclNativeCreateNativeRep --
*
- * Create a native representation for the given path.
+ * Create a native representation for the given path.
*
* Results:
- * The nativePath representation.
+ * The nativePath representation.
*
* Side effects:
- * Memory will be allocated. The path may need to be normalized.
+ * Memory will be allocated. The path may need to be normalized.
*
*---------------------------------------------------------------------------
*/
-ClientData
+
+ClientData
TclNativeCreateNativeRep(pathPtr)
Tcl_Obj* pathPtr;
{
@@ -2906,15 +3197,18 @@ TclNativeCreateNativeRep(pathPtr)
char *str;
if (TclFSCwdIsNative()) {
- /*
- * The cwd is native, which means we can use the translated
- * path without worrying about normalization (this will also
- * usually be shorter so the utf-to-external conversion will
- * be somewhat faster).
+ /*
+ * The cwd is native, which means we can use the translated path
+ * without worrying about normalization (this will also usually be
+ * shorter so the utf-to-external conversion will be somewhat faster).
*/
+
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
} else {
- /* Make sure the normalized path is set */
+ /*
+ * Make sure the normalized path is set.
+ */
+
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
Tcl_IncrRefCount(validPathPtr);
}
@@ -2929,7 +3223,7 @@ TclNativeCreateNativeRep(pathPtr)
Tcl_DecrRefCount(validPathPtr);
nativePathPtr = ckalloc((unsigned) len);
memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);
-
+
Tcl_DStringFree(&ds);
return (ClientData)nativePathPtr;
}
@@ -2939,18 +3233,19 @@ TclNativeCreateNativeRep(pathPtr)
*
* TclNativeDupInternalRep --
*
- * Duplicate the native representation.
+ * Duplicate the native representation.
*
* Results:
- * The copied native representation, or NULL if it is not possible
- * to copy the representation.
+ * The copied native representation, or NULL if it is not possible to
+ * copy the representation.
*
* Side effects:
* Memory allocation for the copy.
*
*---------------------------------------------------------------------------
*/
-ClientData
+
+ClientData
TclNativeDupInternalRep(clientData)
ClientData clientData;
{
@@ -2962,16 +3257,22 @@ TclNativeDupInternalRep(clientData)
}
if (tclWinProcs->useWide) {
- /* unicode representation when running on NT/2K/XP */
- len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR));
+ /*
+ * Unicode representation when running on NT/2K/XP.
+ */
+
+ len = sizeof(WCHAR) * (wcslen((CONST WCHAR *) clientData) + 1);
} else {
- /* ansi representation when running on 95/98/ME */
- len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
+ /*
+ * ANSI representation when running on 95/98/ME.
+ */
+
+ len = sizeof(char) * (strlen((CONST char *) clientData) + 1);
}
-
+
copy = (char *) ckalloc(len);
- memcpy((VOID*)copy, (VOID*)clientData, len);
- return (ClientData)copy;
+ memcpy((VOID *) copy, (VOID *) clientData, len);
+ return (ClientData) copy;
}
/*
@@ -2985,34 +3286,35 @@ TclNativeDupInternalRep(clientData)
* 0 on success, -1 on error.
*
* Side effects:
- * Sets errno to a representation of any Windows problem that's
- * observed in the process.
+ * Sets errno to a representation of any Windows problem that's observed
+ * in the process.
*
*---------------------------------------------------------------------------
*/
int
TclpUtime(pathPtr, tval)
- Tcl_Obj *pathPtr; /* File to modify */
- struct utimbuf *tval; /* New modification date structure */
+ Tcl_Obj *pathPtr; /* File to modify */
+ struct utimbuf *tval; /* New modification date structure */
{
int res = 0;
HANDLE fileHandle;
FILETIME lastAccessTime, lastModTime;
-
+
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
-
+
/*
- * We use the native APIs (not 'utime') because there are
- * some daylight savings complications that utime gets wrong.
+ * We use the native APIs (not 'utime') because there are some daylight
+ * savings complications that utime gets wrong.
*/
+
fileHandle = (tclWinProcs->createFileProc) (
- (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr),
- FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING,
- FILE_ATTRIBUTE_NORMAL, NULL);
-
- if (fileHandle == INVALID_HANDLE_VALUE
- || !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
+ (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr),
+ FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING,
+ FILE_ATTRIBUTE_NORMAL, NULL);
+
+ if (fileHandle == INVALID_HANDLE_VALUE ||
+ !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
TclWinConvertError(GetLastError());
res = -1;
}
@@ -3021,3 +3323,11 @@ TclpUtime(pathPtr, tval)
}
return res;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index 08b3d14..a46fc80 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -7,7 +7,10 @@
* Copyright (c) 1998-1999 by Scriptics Corporation.
* All rights reserved.
*
- * RCS: @(#) $Id: tclWinInit.c,v 1.66 2005/05/10 18:35:39 kennykb Exp $
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclWinInit.c,v 1.67 2005/07/24 22:56:48 dkf Exp $
*/
#include "tclWinInt.h"
@@ -25,8 +28,8 @@
/*
* The following declaration is a workaround for some Microsoft brain damage.
* The SYSTEM_INFO structure is different in various releases, even though the
- * layout is the same. So we overlay our own structure on top of it so we
- * can access the interesting slots in a uniform way.
+ * layout is the same. So we overlay our own structure on top of it so we can
+ * access the interesting slots in a uniform way.
*/
typedef struct {
@@ -39,40 +42,40 @@ typedef struct {
*/
#ifndef PROCESSOR_ARCHITECTURE_INTEL
-#define PROCESSOR_ARCHITECTURE_INTEL 0
+#define PROCESSOR_ARCHITECTURE_INTEL 0
#endif
#ifndef PROCESSOR_ARCHITECTURE_MIPS
-#define PROCESSOR_ARCHITECTURE_MIPS 1
+#define PROCESSOR_ARCHITECTURE_MIPS 1
#endif
#ifndef PROCESSOR_ARCHITECTURE_ALPHA
-#define PROCESSOR_ARCHITECTURE_ALPHA 2
+#define PROCESSOR_ARCHITECTURE_ALPHA 2
#endif
#ifndef PROCESSOR_ARCHITECTURE_PPC
-#define PROCESSOR_ARCHITECTURE_PPC 3
+#define PROCESSOR_ARCHITECTURE_PPC 3
#endif
#ifndef PROCESSOR_ARCHITECTURE_SHX
-#define PROCESSOR_ARCHITECTURE_SHX 4
+#define PROCESSOR_ARCHITECTURE_SHX 4
#endif
#ifndef PROCESSOR_ARCHITECTURE_ARM
-#define PROCESSOR_ARCHITECTURE_ARM 5
+#define PROCESSOR_ARCHITECTURE_ARM 5
#endif
#ifndef PROCESSOR_ARCHITECTURE_IA64
-#define PROCESSOR_ARCHITECTURE_IA64 6
+#define PROCESSOR_ARCHITECTURE_IA64 6
#endif
#ifndef PROCESSOR_ARCHITECTURE_ALPHA64
-#define PROCESSOR_ARCHITECTURE_ALPHA64 7
+#define PROCESSOR_ARCHITECTURE_ALPHA64 7
#endif
#ifndef PROCESSOR_ARCHITECTURE_MSIL
-#define PROCESSOR_ARCHITECTURE_MSIL 8
+#define PROCESSOR_ARCHITECTURE_MSIL 8
#endif
#ifndef PROCESSOR_ARCHITECTURE_AMD64
-#define PROCESSOR_ARCHITECTURE_AMD64 9
+#define PROCESSOR_ARCHITECTURE_AMD64 9
#endif
#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
-#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10
+#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10
#endif
#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
-#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
+#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
#endif
/*
@@ -95,6 +98,7 @@ static char* processors[NUMPROCESSORS] = {
/*
* The default directory in which the init.tcl file is expected to be found.
*/
+
static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir;
static ProcessGlobalValue defaultLibraryDir =
{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};
@@ -127,14 +131,13 @@ TclpInitPlatform()
tclPlatform = TCL_PLATFORM_WINDOWS;
/*
- * The following code stops Windows 3.X and Windows NT 3.51 from
- * automatically putting up Sharing Violation dialogs, e.g, when
- * someone tries to access a file that is locked or a drive with no
- * disk in it. Tcl already returns the appropriate error to the
- * caller, and they can decide to put up their own dialog in response
- * to that failure.
+ * The following code stops Windows 3.X and Windows NT 3.51 from
+ * automatically putting up Sharing Violation dialogs, e.g, when someone
+ * tries to access a file that is locked or a drive with no disk in it.
+ * Tcl already returns the appropriate error to the caller, and they can
+ * decide to put up their own dialog in response to that failure.
*
- * Under 95 and NT 4.0, this is a NOOP because the system doesn't
+ * Under 95 and NT 4.0, this is a NOOP because the system doesn't
* automatically put up dialogs when the above operations fail.
*/
@@ -142,9 +145,9 @@ TclpInitPlatform()
#ifdef STATIC_BUILD
/*
- * If we are in a statically linked executable, then we need to
- * explicitly initialize the Windows function tables here since
- * DllMain() will not be invoked.
+ * If we are in a statically linked executable, then we need to explicitly
+ * initialize the Windows function tables here since DllMain() will not be
+ * invoked.
*/
TclWinInit(GetModuleHandle(NULL));
@@ -156,15 +159,14 @@ TclpInitPlatform()
*
* TclpInitLibraryPath --
*
- * This is the fallback routine that sets the library path
- * if the application has not set one by the first time
- * it is needed.
+ * This is the fallback routine that sets the library path if the
+ * application has not set one by the first time it is needed.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * Sets the library path to an initial value.
+ * Sets the library path to an initial value.
*
*-------------------------------------------------------------------------
*/
@@ -183,7 +185,7 @@ TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr)
pathPtr = Tcl_NewObj();
/*
- * Initialize the substring used when locating the script library. The
+ * Initialize the substring used when locating the script library. The
* installLib variable computes the script library path relative to the
* installed DLL.
*/
@@ -191,10 +193,10 @@ TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr)
sprintf(installLib, "lib/tcl%s", TCL_VERSION);
/*
- * Look for the library relative to the TCL_LIBRARY env variable.
- * If the last dirname in the TCL_LIBRARY path does not match the
- * last dirname in the installLib variable, use the last dir name
- * of installLib in addition to the orginal TCL_LIBRARY path.
+ * Look for the library relative to the TCL_LIBRARY env variable. If the
+ * last dirname in the TCL_LIBRARY path does not match the last dirname in
+ * the installLib variable, use the last dir name of installLib in
+ * addition to the orginal TCL_LIBRARY path.
*/
AppendEnvironment(pathPtr, installLib);
@@ -202,6 +204,7 @@ TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr)
/*
* Look for the library in its default location.
*/
+
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&defaultLibraryDir));
@@ -217,9 +220,9 @@ TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr)
*
* AppendEnvironment --
*
- * Append the value of the TCL_LIBRARY environment variable onto the
- * path pointer. If the env variable points to another version of
- * tcl (e.g. "tcl7.6") also append the path to this version (e.g.,
+ * Append the value of the TCL_LIBRARY environment variable onto the path
+ * pointer. If the env variable points to another version of tcl (e.g.
+ * "tcl7.6") also append the path to this version (e.g.,
* "tcl7.6/../tcl8.2")
*
* Results:
@@ -245,10 +248,10 @@ AppendEnvironment(
char *shortlib;
/*
- * The shortlib value needs to be the tail component of the
- * lib path. For example, "lib/tcl8.4" -> "tcl8.4" while
- * "usr/share/tcl8.5" -> "tcl8.5".
+ * The shortlib value needs to be the tail component of the lib path. For
+ * example, "lib/tcl8.4" -> "tcl8.4" while "usr/share/tcl8.5" -> "tcl8.5".
*/
+
for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) {
if (*shortlib == '/') {
if ((unsigned)(shortlib - lib) == strlen(lib) - 1) {
@@ -263,8 +266,8 @@ AppendEnvironment(
}
/*
- * The "L" preceeding the TCL_LIBRARY string is used to tell VC++
- * that this is a unicode string.
+ * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that
+ * this is a unicode string.
*/
if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
@@ -282,18 +285,18 @@ AppendEnvironment(
Tcl_SplitPath(buf, &pathc, &pathv);
/*
- * The lstrcmpi() will work even if pathv[pathc - 1] is random
- * UTF-8 chars because I know shortlib is ascii.
+ * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8
+ * chars because I know shortlib is ascii.
*/
if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) {
CONST char *str;
+
/*
- * TCL_LIBRARY is set but refers to a different tcl
- * installation than the current version. Try fiddling with the
- * specified directory to make it refer to this installation by
- * removing the old "tclX.Y" and substituting the current
- * version string.
+ * TCL_LIBRARY is set but refers to a different tcl installation
+ * than the current version. Try fiddling with the specified
+ * directory to make it refer to this installation by removing the
+ * old "tclX.Y" and substituting the current version string.
*/
pathv[pathc - 1] = shortlib;
@@ -314,8 +317,8 @@ AppendEnvironment(
*
* InitializeDefaultLibraryDir --
*
- * Locate the Tcl script library default location relative to
- * the location of the Tcl DLL.
+ * Locate the Tcl script library default location relative to the
+ * location of the Tcl DLL.
*
* Results:
* None.
@@ -342,13 +345,15 @@ InitializeDefaultLibraryDir(valuePtr, lengthPtr, encodingPtr)
} else {
ToUtf(wName, name);
}
- end = strrchr(name, '\\');
- *end = '\0';
- p = strrchr(name, '\\');
- if (p != NULL) {
- end = p;
- }
- *end = '\\';
+
+ end = strrchr(name, '\\');
+ *end = '\0';
+ p = strrchr(name, '\\');
+ if (p != NULL) {
+ end = p;
+ }
+ *end = '\\';
+
TclWinNoBackslash(name);
sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
*lengthPtr = strlen(name);
@@ -394,10 +399,10 @@ ToUtf(
*
* TclWinEncodingsCleanup --
*
- * Reset information to its original state in finalization to
- * allow for reinitialization to be possible. This must not
- * be called until after the filesystem has been finalised, or
- * exit crashes may occur when using virtual filesystems.
+ * Reset information to its original state in finalization to allow for
+ * reinitialization to be possible. This must not be called until after
+ * the filesystem has been finalised, or exit crashes may occur when
+ * using virtual filesystems.
*
* Results:
* None.
@@ -419,21 +424,21 @@ TclWinEncodingsCleanup()
*
* TclpSetInitialEncodings --
*
- * Based on the locale, determine the encoding of the operating
- * system and the default encoding for newly opened files.
+ * Based on the locale, determine the encoding of the operating system
+ * and the default encoding for newly opened files.
*
- * Called at process initialization time, and part way through
- * startup, we verify that the initial encodings were correctly
- * setup. Depending on Tcl's environment, there may not have been
- * enough information first time through (above).
+ * Called at process initialization time, and part way through startup,
+ * we verify that the initial encodings were correctly setup. Depending
+ * on Tcl's environment, there may not have been enough information first
+ * time through (above).
*
* Results:
* None.
*
* Side effects:
- * The Tcl library path is converted from native encoding to UTF-8,
- * on the first call, and the encodings may be changed on first or
- * second call.
+ * The Tcl library path is converted from native encoding to UTF-8, on
+ * the first call, and the encodings may be changed on first or second
+ * call.
*
*---------------------------------------------------------------------------
*/
@@ -453,6 +458,7 @@ void
TclpSetInterfaces()
{
int platformId, useWide;
+
platformId = TclWinGetPlatformId();
useWide = ((platformId == VER_PLATFORM_WIN32_NT)
|| (platformId == VER_PLATFORM_WIN32_CE));
@@ -473,9 +479,8 @@ TclpGetEncodingNameFromEnvironment(bufPtr)
*
* TclpSetVariables --
*
- * Performs platform-specific interpreter initialization related to
- * the tcl_platform and env variables, and other platform-specific
- * things.
+ * Performs platform-specific interpreter initialization related to the
+ * tcl_platform and env variables, and other platform-specific things.
*
* Results:
* None.
@@ -528,10 +533,11 @@ TclpSetVariables(interp)
#ifdef _DEBUG
/*
- * The existence of the "debug" element of the tcl_platform array indicates
- * that this particular Tcl shell has been compiled with debug information.
- * Using "info exists tcl_platform(debug)" a Tcl script can direct the
- * interpreter to load debug versions of DLLs with the load command.
+ * The existence of the "debug" element of the tcl_platform array
+ * indicates that this particular Tcl shell has been compiled with debug
+ * information. Using "info exists tcl_platform(debug)" a Tcl script can
+ * direct the interpreter to load debug versions of DLLs with the load
+ * command.
*/
Tcl_SetVar2(interp, "tcl_platform", "debug", "1",
@@ -583,15 +589,14 @@ TclpSetVariables(interp)
*
* TclpFindVariable --
*
- * Locate the entry in environ for a given name. On Unix this
- * routine is case sensetive, on Windows this matches mioxed case.
+ * Locate the entry in environ for a given name. On Unix this routine is
+ * case sensetive, on Windows this matches mioxed case.
*
* Results:
- * The return value is the index in environ of an entry with the
- * name "name", or -1 if there is no such entry. The integer at
- * *lengthPtr is filled in with the length of name (if a matching
- * entry is found) or the length of the environ array (if no matching
- * entry is found).
+ * The return value is the index in environ of an entry with the name
+ * "name", or -1 if there is no such entry. The integer at *lengthPtr is
+ * filled in with the length of name (if a matching entry is found) or
+ * the length of the environ array (if no matching entry is found).
*
* Side effects:
* None.
@@ -614,8 +619,7 @@ TclpFindVariable(name, lengthPtr)
Tcl_DString envString;
/*
- * Convert the name to all upper case for the case insensitive
- * comparison.
+ * Convert the name to all upper case for the case insensitive comparison.
*/
length = strlen(name);
@@ -626,9 +630,9 @@ TclpFindVariable(name, lengthPtr)
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
/*
- * Chop the env string off after the equal sign, then Convert
- * the name to all upper case, so we do not have to convert
- * all the characters after the equal sign.
+ * Chop the env string off after the equal sign, then Convert the name
+ * to all upper case, so we do not have to convert all the characters
+ * after the equal sign.
*/
envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
@@ -656,8 +660,16 @@ TclpFindVariable(name, lengthPtr)
*lengthPtr = i;
- done:
+ done:
Tcl_DStringFree(&envString);
ckfree(nameUpper);
return result;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index 0bd0fca..34d98e3 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -1,16 +1,16 @@
-/*
+/*
* tclWinLoad.c --
*
- * This procedure provides a version of the TclLoadFile that
- * works with the Windows "LoadLibrary" and "GetProcAddress"
- * API for dynamic loading.
+ * This function provides a version of the TclLoadFile that works with
+ * the Windows "LoadLibrary" and "GetProcAddress" API for dynamic
+ * loading.
*
* Copyright (c) 1995-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: tclWinLoad.c,v 1.17 2003/09/08 20:12:07 davygrvy Exp $
+ * RCS: @(#) $Id: tclWinLoad.c,v 1.18 2005/07/24 22:56:49 dkf Exp $
*/
#include "tclWinInt.h"
@@ -21,12 +21,12 @@
*
* TclpDlopen --
*
- * Dynamically loads a binary code file into memory and returns
- * a handle to the new code.
+ * Dynamically loads a binary code file into memory and returns a handle
+ * to the new code.
*
* Results:
- * A standard Tcl completion code. If an error occurs, an error
- * message is left in the interp's result.
+ * A standard Tcl completion code. If an error occurs, an error message
+ * is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory.
@@ -40,87 +40,93 @@ TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
- * file which will be passed back to
+ * file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
- Tcl_FSUnloadFileProc **unloadProcPtr;
+ Tcl_FSUnloadFileProc **unloadProcPtr;
/* Filled with address of Tcl_FSUnloadFileProc
- * function which should be used for
- * this file. */
+ * function which should be used for this
+ * file. */
{
HINSTANCE handle;
CONST TCHAR *nativeName;
- /*
- * First try the full path the user gave us. This is particularly
- * important if the cwd is inside a vfs, and we are trying to load
- * using a relative path.
+ /*
+ * First try the full path the user gave us. This is particularly
+ * important if the cwd is inside a vfs, and we are trying to load using a
+ * relative path.
*/
+
nativeName = Tcl_FSGetNativePath(pathPtr);
handle = (*tclWinProcs->loadLibraryProc)(nativeName);
if (handle == NULL) {
- /*
- * Let the OS loader examine the binary search path for
- * whatever string the user gave us which hopefully refers
- * to a file on the binary path
+ /*
+ * Let the OS loader examine the binary search path for whatever
+ * string the user gave us which hopefully refers to a file on the
+ * binary path.
*/
+
Tcl_DString ds;
- char *fileName = Tcl_GetString(pathPtr);
+ char *fileName = Tcl_GetString(pathPtr);
+
nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
handle = (*tclWinProcs->loadLibraryProc)(nativeName);
Tcl_DStringFree(&ds);
}
*loadHandle = (Tcl_LoadHandle) handle;
-
+
if (handle == NULL) {
DWORD lastError = GetLastError();
+
#if 0
/*
- * It would be ideal if the FormatMessage stuff worked better,
- * but unfortunately it doesn't seem to want to...
+ * It would be ideal if the FormatMessage stuff worked better, but
+ * unfortunately it doesn't seem to want to...
*/
+
LPTSTR lpMsgBuf;
char *buf;
int size;
+
size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0,
(LPTSTR) &lpMsgBuf, 0, NULL);
buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1);
sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);
#endif
+
Tcl_AppendResult(interp, "couldn't load library \"",
- Tcl_GetString(pathPtr), "\": ", (char *) NULL);
+ Tcl_GetString(pathPtr), "\": ", (char *) NULL);
+
/*
- * Check for possible DLL errors. This doesn't work quite right,
- * because Windows seems to only return ERROR_MOD_NOT_FOUND for
- * just about any problem, but it's better than nothing. It'd be
- * even better if there was a way to get what DLLs
+ * Check for possible DLL errors. This doesn't work quite right,
+ * because Windows seems to only return ERROR_MOD_NOT_FOUND for just
+ * about any problem, but it's better than nothing. It'd be even
+ * better if there was a way to get what DLLs
*/
+
switch (lastError) {
- case ERROR_MOD_NOT_FOUND:
- case ERROR_DLL_NOT_FOUND:
- Tcl_AppendResult(interp, "this library or a dependent library",
- " could not be found in library path",
- (char *) NULL);
- break;
- case ERROR_PROC_NOT_FOUND:
- Tcl_AppendResult(interp, "A function specified in the import",
- " table could not be resolved by the system. Windows",
- " is not telling which one, I'm sorry.",
- (char *) NULL);
- break;
- case ERROR_INVALID_DLL:
- Tcl_AppendResult(interp, "this library or a dependent library",
- " is damaged", (char *) NULL);
- break;
- case ERROR_DLL_INIT_FAILED:
- Tcl_AppendResult(interp, "the library initialization",
- " routine failed", (char *) NULL);
- break;
- default:
- TclWinConvertError(lastError);
- Tcl_AppendResult(interp, Tcl_PosixError(interp),
- (char *) NULL);
+ case ERROR_MOD_NOT_FOUND:
+ case ERROR_DLL_NOT_FOUND:
+ Tcl_AppendResult(interp, "this library or a dependent library",
+ " could not be found in library path", (char *) NULL);
+ break;
+ case ERROR_PROC_NOT_FOUND:
+ Tcl_AppendResult(interp, "A function specified in the import",
+ " table could not be resolved by the system. Windows",
+ " is not telling which one, I'm sorry.", (char *) NULL);
+ break;
+ case ERROR_INVALID_DLL:
+ Tcl_AppendResult(interp, "this library or a dependent library",
+ " is damaged", (char *) NULL);
+ break;
+ case ERROR_DLL_INIT_FAILED:
+ Tcl_AppendResult(interp, "the library initialization",
+ " routine failed", (char *) NULL);
+ break;
+ default:
+ TclWinConvertError(lastError);
+ Tcl_AppendResult(interp, Tcl_PosixError(interp), (char *) NULL);
}
return TCL_ERROR;
} else {
@@ -134,18 +140,19 @@ TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
*
* TclpFindSymbol --
*
- * Looks up a symbol, by name, through a handle associated with
- * a previously loaded piece of code (shared library).
+ * Looks up a symbol, by name, through a handle associated with a
+ * previously loaded piece of code (shared library).
*
* Results:
- * Returns a pointer to the function associated with 'symbol' if
- * it is found. Otherwise returns NULL and may leave an error
- * message in the interp's result.
+ * Returns a pointer to the function associated with 'symbol' if it is
+ * found. Otherwise returns NULL and may leave an error message in the
+ * interp's result.
*
*----------------------------------------------------------------------
*/
+
Tcl_PackageInitProc*
-TclpFindSymbol(interp, loadHandle, symbol)
+TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
@@ -161,6 +168,7 @@ TclpFindSymbol(interp, loadHandle, symbol)
proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
if (proc == NULL) {
Tcl_DString ds;
+
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "_", 1);
symbol = Tcl_DStringAppend(&ds, symbol, -1);
@@ -175,9 +183,9 @@ TclpFindSymbol(interp, loadHandle, symbol)
*
* TclpUnloadFile --
*
- * Unloads a dynamically loaded binary code file from memory.
- * Code pointers in the formerly loaded file are no longer valid
- * after calling this function.
+ * Unloads a dynamically loaded binary code file from memory. Code
+ * pointers in the formerly loaded file are no longer valid after calling
+ * this function.
*
* Results:
* None.
@@ -190,10 +198,9 @@ TclpFindSymbol(interp, loadHandle, symbol)
void
TclpUnloadFile(loadHandle)
- Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
- * to TclpDlopen(). The loadHandle is
- * a token that represents the loaded
- * file. */
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to
+ * TclpDlopen(). The loadHandle is a token
+ * that represents the loaded file. */
{
HINSTANCE handle;
@@ -206,14 +213,14 @@ TclpUnloadFile(loadHandle)
*
* TclGuessPackageName --
*
- * If the "load" command is invoked without providing a package
- * name, this procedure is invoked to try to figure it out.
+ * If the "load" command is invoked without providing a package name,
+ * this function is invoked to try to figure it out.
*
* Results:
- * Always returns 0 to indicate that we couldn't figure out a
- * package name; generic code will then try to guess the package
- * from the file name. A return value of 1 would have meant that
- * we figured out the package name and put it in bufPtr.
+ * Always returns 0 to indicate that we couldn't figure out a package
+ * name; generic code will then try to guess the package from the file
+ * name. A return value of 1 would have meant that we figured out the
+ * package name and put it in bufPtr.
*
* Side effects:
* None.
@@ -225,8 +232,16 @@ int
TclGuessPackageName(fileName, bufPtr)
CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
- Tcl_DString *bufPtr; /* Initialized empty dstring. Append
- * package name to this if possible. */
+ Tcl_DString *bufPtr; /* Initialized empty dstring. Append package
+ * name to this if possible. */
{
return 0;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c
index 5a641c1..dc8a683 100644
--- a/win/tclWinNotify.c
+++ b/win/tclWinNotify.c
@@ -1,16 +1,16 @@
-/*
+/*
* tclWinNotify.c --
*
- * This file contains Windows-specific procedures for the notifier,
- * which is the lowest-level part of the Tcl event loop. This file
- * works together with ../generic/tclNotify.c.
+ * This file contains Windows-specific procedures for the notifier, which
+ * is the lowest-level part of the Tcl event loop. This file works
+ * together with ../generic/tclNotify.c.
*
* Copyright (c) 1995-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: tclWinNotify.c,v 1.19 2005/05/10 18:35:40 kennykb Exp $
+ * RCS: @(#) $Id: tclWinNotify.c,v 1.20 2005/07/24 22:56:49 dkf Exp $
*/
#include "tclInt.h"
@@ -19,14 +19,14 @@
* The follwing static indicates whether this module has been initialized.
*/
-#define INTERVAL_TIMER 1 /* Handle of interval timer. */
+#define INTERVAL_TIMER 1 /* Handle of interval timer. */
-#define WM_WAKEUP WM_USER /* Message that is send by
+#define WM_WAKEUP WM_USER /* Message that is send by
* Tcl_AlertNotifier. */
/*
* The following static structure contains the state information for the
- * Windows implementation of the Tcl notifier. One of these structures
- * is created for each thread that is using the notifier.
+ * Windows implementation of the Tcl notifier. One of these structures is
+ * created for each thread that is using the notifier.
*/
typedef struct ThreadSpecificData {
@@ -35,8 +35,8 @@ typedef struct ThreadSpecificData {
* notifier. */
HANDLE event; /* Event object used to wake up the notifier
* thread. */
- int pending; /* Alert message pending, this field is
- * locked by the notifierMutex. */
+ int pending; /* Alert message pending, this field is locked
+ * by the notifierMutex. */
HWND hwnd; /* Messaging window. */
int timeout; /* Current timeout value. */
int timerActive; /* 1 if interval timer is running. */
@@ -48,9 +48,8 @@ extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;
/*
- * The following static indicates the number of threads that have
- * initialized notifiers. It controls the lifetime of the TclNotifier
- * window class.
+ * The following static indicates the number of threads that have initialized
+ * notifiers. It controls the lifetime of the TclNotifier window class.
*
* You must hold the notifierMutex lock before accessing this variable.
*/
@@ -62,9 +61,8 @@ TCL_DECLARE_MUTEX(notifierMutex)
* Static routines defined in this file.
*/
-static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message,
- WPARAM wParam, LPARAM lParam);
-
+static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message,
+ WPARAM wParam, LPARAM lParam);
/*
*----------------------------------------------------------------------
@@ -89,8 +87,8 @@ Tcl_InitNotifier()
WNDCLASS class;
/*
- * Register Notifier window class if this is the first thread to
- * use this module.
+ * Register Notifier window class if this is the first thread to use this
+ * module.
*/
Tcl_MutexLock(&notifierMutex);
@@ -131,8 +129,8 @@ Tcl_InitNotifier()
*
* Tcl_FinalizeNotifier --
*
- * This function is called to cleanup the notifier state before
- * a thread is terminated.
+ * This function is called to cleanup the notifier state before a thread
+ * is terminated.
*
* Results:
* None.
@@ -150,15 +148,16 @@ Tcl_FinalizeNotifier(clientData)
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
/*
- * Only finalize the notifier if a notifier was installed in the
- * current thread; there is a route in which this is not
- * guaranteed to be true (when tclWin32Dll.c:DllMain() is called
- * with the flag DLL_PROCESS_DETACH by the OS, which could be
- * doing so from a thread that's never previously been involved
- * with Tcl, e.g. the task manager) so this check is important.
+ * Only finalize the notifier if a notifier was installed in the current
+ * thread; there is a route in which this is not guaranteed to be true
+ * (when tclWin32Dll.c:DllMain() is called with the flag
+ * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread
+ * that's never previously been involved with Tcl, e.g. the task manager)
+ * so this check is important.
*
* Fixes Bug #217982 reported by Hugh Vu and Gene Leache.
*/
+
if (tsdPtr == NULL) {
return;
}
@@ -176,8 +175,8 @@ Tcl_FinalizeNotifier(clientData)
}
/*
- * If this is the last thread to use the notifier, unregister
- * the notifier window class.
+ * If this is the last thread to use the notifier, unregister the notifier
+ * window class.
*/
Tcl_MutexLock(&notifierMutex);
@@ -193,20 +192,19 @@ Tcl_FinalizeNotifier(clientData)
*
* Tcl_AlertNotifier --
*
- * Wake up the specified notifier from any thread. This routine
- * is called by the platform independent notifier code whenever
- * the Tcl_ThreadAlert routine is called. This routine is
- * guaranteed not to be called on a given notifier after
- * Tcl_FinalizeNotifier is called for that notifier. This routine
- * is typically called from a thread other than the notifier's
- * thread.
+ * Wake up the specified notifier from any thread. This routine is called
+ * by the platform independent notifier code whenever the Tcl_ThreadAlert
+ * routine is called. This routine is guaranteed not to be called on a
+ * given notifier after Tcl_FinalizeNotifier is called for that notifier.
+ * This routine is typically called from a thread other than the
+ * notifier's thread.
*
* Results:
* None.
*
* Side effects:
- * Sends a message to the messaging window for the notifier
- * if there isn't already one pending.
+ * Sends a message to the messaging window for the notifier if there
+ * isn't already one pending.
*
*----------------------------------------------------------------------
*/
@@ -218,9 +216,9 @@ Tcl_AlertNotifier(clientData)
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
/*
- * Note that we do not need to lock around access to the hwnd
- * because the race condition has no effect since any race condition
- * implies that the notifier thread is already awake.
+ * Note that we do not need to lock around access to the hwnd because the
+ * race condition has no effect since any race condition implies that the
+ * notifier thread is already awake.
*/
if (tsdPtr->hwnd) {
@@ -244,9 +242,9 @@ Tcl_AlertNotifier(clientData)
*
* Tcl_SetTimer --
*
- * This procedure sets the current notifier timer value. The
- * notifier will ensure that Tcl_ServiceAll() is called after
- * the specified interval, even if no events have occurred.
+ * This procedure sets the current notifier timer value. The notifier
+ * will ensure that Tcl_ServiceAll() is called after the specified
+ * interval, even if no events have occurred.
*
* Results:
* None.
@@ -265,8 +263,8 @@ Tcl_SetTimer(
UINT timeout;
/*
- * Allow the notifier to be hooked. This may not make sense
- * on Windows, but mirrors the UNIX hook.
+ * Allow the notifier to be hooked. This may not make sense on Windows,
+ * but mirrors the UNIX hook.
*/
if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
@@ -275,10 +273,9 @@ Tcl_SetTimer(
}
/*
- * We only need to set up an interval timer if we're being called
- * from an external event loop. If we don't have a window handle
- * then we just return immediately and let Tcl_WaitForEvent handle
- * timeouts.
+ * We only need to set up an interval timer if we're being called from an
+ * external event loop. If we don't have a window handle then we just
+ * return immediately and let Tcl_WaitForEvent handle timeouts.
*/
if (!tsdPtr->hwnd) {
@@ -301,8 +298,8 @@ Tcl_SetTimer(
tsdPtr->timeout = timeout;
if (timeout != 0) {
tsdPtr->timerActive = 1;
- SetTimer(tsdPtr->hwnd, INTERVAL_TIMER,
- (unsigned long) tsdPtr->timeout, NULL);
+ SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, (unsigned long) tsdPtr->timeout,
+ NULL);
} else {
tsdPtr->timerActive = 0;
KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
@@ -320,8 +317,8 @@ Tcl_SetTimer(
* None.
*
* Side effects:
- * If this is the first time the notifier is set into
- * TCL_SERVICE_ALL, then the communication window is created.
+ * If this is the first time the notifier is set into TCL_SERVICE_ALL,
+ * then the communication window is created.
*
*----------------------------------------------------------------------
*/
@@ -334,23 +331,23 @@ Tcl_ServiceModeHook(mode)
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * If this is the first time that the notifier has been used from a
- * modal loop, then create a communication window. Note that after
- * this point, the application needs to service events in a timely
- * fashion or Windows will hang waiting for the window to respond
- * to synchronous system messages. At some point, we may want to
- * consider destroying the window if we leave the modal loop, but
- * for now we'll leave it around.
+ * If this is the first time that the notifier has been used from a modal
+ * loop, then create a communication window. Note that after this point,
+ * the application needs to service events in a timely fashion or Windows
+ * will hang waiting for the window to respond to synchronous system
+ * messages. At some point, we may want to consider destroying the window
+ * if we leave the modal loop, but for now we'll leave it around.
*/
if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED,
0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);
+
/*
* Send an initial message to the window to ensure that we wake up the
- * notifier once we get into the modal loop. This will force the
- * notifier to recompute the timeout value and schedule a timer
- * if one is needed.
+ * notifier once we get into the modal loop. This will force the
+ * notifier to recompute the timeout value and schedule a timer if one
+ * is needed.
*/
Tcl_AlertNotifier((ClientData)tsdPtr);
@@ -362,10 +359,9 @@ Tcl_ServiceModeHook(mode)
*
* NotifierProc --
*
- * This procedure is invoked by Windows to process events on
- * the notifier window. Messages will be sent to this window
- * in response to external timer events or calls to
- * TclpAlertTsdPtr->
+ * This procedure is invoked by Windows to process events on the notifier
+ * window. Messages will be sent to this window in response to external
+ * timer events or calls to TclpAlertTsdPtr->
*
* Results:
* A standard windows result.
@@ -378,10 +374,10 @@ Tcl_ServiceModeHook(mode)
static LRESULT CALLBACK
NotifierProc(
- HWND hwnd,
- UINT message,
- WPARAM wParam,
- LPARAM lParam)
+ HWND hwnd, /* Passed on... */
+ UINT message, /* What messsage is this? */
+ WPARAM wParam, /* Passed on... */
+ LPARAM lParam) /* Passed on... */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -392,7 +388,7 @@ NotifierProc(
} else if (message != WM_TIMER) {
return DefWindowProc(hwnd, message, wParam, lParam);
}
-
+
/*
* Process all of the runnable events.
*/
@@ -406,17 +402,16 @@ NotifierProc(
*
* Tcl_WaitForEvent --
*
- * This function is called by Tcl_DoOneEvent to wait for new
- * events on the message queue. If the block time is 0, then
- * Tcl_WaitForEvent just polls the event queue without blocking.
+ * This function is called by Tcl_DoOneEvent to wait for new events on
+ * the message queue. If the block time is 0, then Tcl_WaitForEvent just
+ * polls the event queue without blocking.
*
* Results:
- * Returns -1 if a WM_QUIT message is detected, returns 1 if
- * a message was dispatched, otherwise returns 0.
+ * Returns -1 if a WM_QUIT message is detected, returns 1 if a message
+ * was dispatched, otherwise returns 0.
*
* Side effects:
- * Dispatches a message to a window procedure, which could do
- * anything.
+ * Dispatches a message to a window procedure, which could do anything.
*
*----------------------------------------------------------------------
*/
@@ -431,8 +426,8 @@ Tcl_WaitForEvent(
int status;
/*
- * Allow the notifier to be hooked. This may not make
- * sense on windows, but mirrors the UNIX hook.
+ * Allow the notifier to be hooked. This may not make sense on windows,
+ * but mirrors the UNIX hook.
*/
if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
@@ -444,12 +439,14 @@ Tcl_WaitForEvent(
*/
if (timePtr) {
- /* TIP #233 (Virtualized Time). Convert virtual domain delay
- * to real-time.
+ /*
+ * TIP #233 (Virtualized Time). Convert virtual domain delay to
+ * real-time.
*/
- Tcl_Time myTime;
- myTime.sec = timePtr->sec;
+ Tcl_Time myTime;
+
+ myTime.sec = timePtr->sec;
myTime.usec = timePtr->usec;
if (myTime.sec != 0 || myTime.usec != 0) {
@@ -470,11 +467,11 @@ Tcl_WaitForEvent(
if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
* Wait for something to happen (a signal from another thread, a
- * message, or timeout) or loop servicing asynchronous procedure
- * calls queued to this thread.
+ * message, or timeout) or loop servicing asynchronous procedure calls
+ * queued to this thread.
*/
-again:
+ again:
result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout,
QS_ALLINPUT, MWMO_ALERTABLE);
if (result == WAIT_IO_COMPLETION) {
@@ -505,7 +502,7 @@ again:
status = -1;
} else if (result == -1) {
/*
- * We got an error from the system. I have no idea why this would
+ * We got an error from the system. I have no idea why this would
* happen, so we'll just unwind.
*/
@@ -519,7 +516,7 @@ again:
status = 0;
}
-end:
+ end:
ResetEvent(tsdPtr->event);
return status;
}
@@ -545,43 +542,45 @@ Tcl_Sleep(ms)
int ms; /* Number of milliseconds to sleep. */
{
/*
- * Simply calling 'Sleep' for the requisite number of milliseconds
- * can make the process appear to wake up early because it isn't
- * synchronized with the CPU performance counter that is used in
- * tclWinTime.c. This behavior is probably benign, but messes
- * up some of the corner cases in the test suite. We get around
- * this problem by repeating the 'Sleep' call as many times
- * as necessary to make the clock advance by the requisite amount.
+ * Simply calling 'Sleep' for the requisite number of milliseconds can
+ * make the process appear to wake up early because it isn't synchronized
+ * with the CPU performance counter that is used in tclWinTime.c. This
+ * behavior is probably benign, but messes up some of the corner cases in
+ * the test suite. We get around this problem by repeating the 'Sleep'
+ * call as many times as necessary to make the clock advance by the
+ * requisite amount.
*/
- Tcl_Time now; /* Current wall clock time */
- Tcl_Time desired; /* Desired wakeup time */
- Tcl_Time vdelay; /* Time to sleep, for scaling virtual -> real */
+ Tcl_Time now; /* Current wall clock time. */
+ Tcl_Time desired; /* Desired wakeup time. */
+ Tcl_Time vdelay; /* Time to sleep, for scaling virtual ->
+ * real. */
DWORD sleepTime; /* Time to sleep, real-time */
vdelay.sec = ms / 1000;
vdelay.usec = (ms % 1000) * 1000;
- Tcl_GetTime( &now );
+ Tcl_GetTime(&now);
desired.sec = now.sec + vdelay.sec;
desired.usec = now.usec + vdelay.usec;
- if ( desired.usec > 1000000 ) {
+ if (desired.usec > 1000000) {
++desired.sec;
desired.usec -= 1000000;
}
- /* TIP #233: Scale delay from virtual to real-time */
+ /*
+ * TIP #233: Scale delay from virtual to real-time.
+ */
(*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData);
sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000;
-
- for ( ; ; ) {
- Sleep( sleepTime );
- Tcl_GetTime( &now );
- if ( now.sec > desired.sec ) {
+
+ for (;;) {
+ Sleep(sleepTime);
+ Tcl_GetTime(&now);
+ if (now.sec > desired.sec) {
break;
- } else if ( ( now.sec == desired.sec )
- && ( now.usec >= desired.usec ) ) {
+ } else if ((now.sec == desired.sec) && (now.usec >= desired.usec)) {
break;
}
@@ -591,5 +590,12 @@ Tcl_Sleep(ms)
(*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData);
sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000;
}
-
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index fc4a3c1..c5814a7 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -1,15 +1,15 @@
-/*
+/*
* tclWinPipe.c --
*
- * This file implements the Windows-specific exec pipeline functions,
- * the "pipe" channel driver, and the "pid" Tcl command.
+ * This file implements the Windows-specific exec pipeline functions, the
+ * "pipe" channel driver, and the "pid" Tcl command.
*
* Copyright (c) 1996-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: tclWinPipe.c,v 1.57 2005/06/22 21:39:01 kennykb Exp $
+ * RCS: @(#) $Id: tclWinPipe.c,v 1.58 2005/07/24 22:56:49 dkf Exp $
*/
#include "tclWinInt.h"
@@ -26,16 +26,16 @@
static int initialized = 0;
/*
- * The pipeMutex locks around access to the initialized and procList variables,
- * and it is used to protect background threads from being terminated while
- * they are using APIs that hold locks.
+ * The pipeMutex locks around access to the initialized and procList
+ * variables, and it is used to protect background threads from being
+ * terminated while they are using APIs that hold locks.
*/
TCL_DECLARE_MUTEX(pipeMutex)
/*
- * The following defines identify the various types of applications that
- * run under windows. There is special case code for the various types.
+ * The following defines identify the various types of applications that run
+ * under windows. There is special case code for the various types.
*/
#define APPL_NONE 0
@@ -44,16 +44,16 @@ TCL_DECLARE_MUTEX(pipeMutex)
#define APPL_WIN32 3
/*
- * The following constants and structures are used to encapsulate the state
- * of various types of files used in a pipeline.
- * This used to have a 1 && 2 that supported Win32s.
+ * The following constants and structures are used to encapsulate the state of
+ * various types of files used in a pipeline. This used to have a 1 && 2 that
+ * supported Win32s.
*/
-#define WIN_FILE 3 /* Basic Win32 file. */
+#define WIN_FILE 3 /* Basic Win32 file. */
/*
- * This structure encapsulates the common state associated with all file
- * types used in a pipeline.
+ * This structure encapsulates the common state associated with all file types
+ * used in a pipeline.
*/
typedef struct WinFile {
@@ -112,66 +112,64 @@ typedef struct PipeInfo {
HANDLE writeThread; /* Handle to writer thread. */
HANDLE readThread; /* Handle to reader thread. */
HANDLE writable; /* Manual-reset event to signal when the
- * writer thread has finished waiting for
- * the current buffer to be written. */
+ * writer thread has finished waiting for the
+ * current buffer to be written. */
HANDLE readable; /* Manual-reset event to signal when the
* reader thread has finished waiting for
* input. */
HANDLE startWriter; /* Auto-reset event used by the main thread to
- * signal when the writer thread should attempt
- * to write to the pipe. */
+ * signal when the writer thread should
+ * attempt to write to the pipe. */
HANDLE stopWriter; /* Manual-reset event used to alert the reader
* thread to fall-out and exit */
HANDLE startReader; /* Auto-reset event used by the main thread to
- * signal when the reader thread should attempt
- * to read from the pipe. */
+ * signal when the reader thread should
+ * attempt to read from the pipe. */
HANDLE stopReader; /* Manual-reset event used to alert the reader
* thread to fall-out and exit */
DWORD writeError; /* An error caused by the last background
- * write. Set to 0 if no error has been
- * detected. This word is shared with the
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
* writer thread so access must be
* synchronized with the writable object.
*/
- char *writeBuf; /* Current background output buffer.
- * Access is synchronized with the writable
- * object. */
- int writeBufLen; /* Size of write buffer. Access is
- * synchronized with the writable
- * object. */
- int toWrite; /* Current amount to be written. Access is
+ char *writeBuf; /* Current background output buffer. Access is
+ * synchronized with the writable object. */
+ int writeBufLen; /* Size of write buffer. Access is
+ * synchronized with the writable object. */
+ int toWrite; /* Current amount to be written. Access is
* synchronized with the writable object. */
int readFlags; /* Flags that are shared with the reader
- * thread. Access is synchronized with the
+ * thread. Access is synchronized with the
* readable object. */
char extraByte; /* Buffer for extra character consumed by
- * reader thread. This byte is shared with
- * the reader thread so access must be
+ * reader thread. This byte is shared with the
+ * reader thread so access must be
* synchronized with the readable object. */
} PipeInfo;
typedef struct ThreadSpecificData {
/*
- * The following pointer refers to the head of the list of pipes
- * that are being watched for file events.
+ * The following pointer refers to the head of the list of pipes that are
+ * being watched for file events.
*/
-
+
PipeInfo *firstPipePtr;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
- * The following structure is what is added to the Tcl event queue when
- * pipe events are generated.
+ * The following structure is what is added to the Tcl event queue when pipe
+ * events are generated.
*/
typedef struct PipeEvent {
- Tcl_Event header; /* Information that is standard for
- * all events. */
- PipeInfo *infoPtr; /* Pointer to pipe info structure. Note
- * that we still have to verify that the
- * pipe exists before dereferencing this
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ PipeInfo *infoPtr; /* Pointer to pipe info structure. Note that
+ * we still have to verify that the pipe
+ * exists before dereferencing this
* pointer. */
} PipeEvent;
@@ -181,7 +179,7 @@ typedef struct PipeEvent {
static int ApplicationType(Tcl_Interp *interp,
const char *fileName, char *fullName);
-static void BuildCommandLine(const char *executable, int argc,
+static void BuildCommandLine(const char *executable, int argc,
CONST char **argv, Tcl_DString *linePtr);
static BOOL HasConsole(void);
static int PipeBlockModeProc(ClientData instanceData, int mode);
@@ -203,13 +201,12 @@ static void PipeWatchProc(ClientData instanceData, int mask);
static DWORD WINAPI PipeWriterThread(LPVOID arg);
static int TempFileName(WCHAR name[MAX_PATH]);
static int WaitForRead(PipeInfo *infoPtr, int blocking);
-
-static void PipeThreadActionProc _ANSI_ARGS_ ((
- ClientData instanceData, int action));
+static void PipeThreadActionProc(ClientData instanceData,
+ int action);
/*
- * This structure describes the channel type structure for command pipe
- * based IO.
+ * This structure describes the channel type structure for command pipe based
+ * I/O.
*/
static Tcl_ChannelType pipeChannelType = {
@@ -227,8 +224,8 @@ static Tcl_ChannelType pipeChannelType = {
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
- NULL, /* wide seek proc */
- PipeThreadActionProc, /* thread action proc */
+ NULL, /* wide seek proc */
+ PipeThreadActionProc, /* thread action proc */
};
/*
@@ -253,8 +250,8 @@ PipeInit()
ThreadSpecificData *tsdPtr;
/*
- * Check the initialized flag first, then check again in the mutex.
- * This is a speed enhancement.
+ * Check the initialized flag first, then check again in the mutex. This
+ * is a speed enhancement.
*/
if (!initialized) {
@@ -280,8 +277,8 @@ PipeInit()
*
* PipeExitHandler --
*
- * This function is called to cleanup the pipe module before
- * Tcl is unloaded.
+ * This function is called to cleanup the pipe module before Tcl is
+ * unloaded.
*
* Results:
* None.
@@ -304,8 +301,8 @@ PipeExitHandler(
*
* TclpFinalizePipes --
*
- * This function is called to cleanup the process list before
- * Tcl is unloaded.
+ * This function is called to cleanup the process list before Tcl is
+ * unloaded.
*
* Results:
* None.
@@ -329,8 +326,8 @@ TclpFinalizePipes()
*
* PipeSetupProc --
*
- * This procedure is invoked before Tcl_DoOneEvent blocks waiting
- * for an event.
+ * This function is invoked before Tcl_DoOneEvent blocks waiting for an
+ * event.
*
* Results:
* None.
@@ -355,12 +352,12 @@ PipeSetupProc(
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
-
+
/*
* Look to see if any events are already pending. If they are, poll.
*/
- for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
+ for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask & TCL_WRITABLE) {
filePtr = (WinFile*) infoPtr->writeFile;
@@ -385,8 +382,8 @@ PipeSetupProc(
*
* PipeCheckProc --
*
- * This procedure is called by Tcl_DoOneEvent to check the pipe
- * event source for events.
+ * This function is called by Tcl_DoOneEvent to check the pipe event
+ * source for events.
*
* Results:
* None.
@@ -411,18 +408,17 @@ PipeCheckProc(
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
-
+
/*
- * Queue events for any ready pipes that don't already have events
- * queued.
+ * Queue events for any ready pipes that don't already have events queued.
*/
- for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
+ for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->flags & PIPE_PENDING) {
continue;
}
-
+
/*
* Queue an event if the pipe is signaled for reading or writing.
*/
@@ -433,7 +429,7 @@ PipeCheckProc(
(WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
needEvent = 1;
}
-
+
filePtr = (WinFile*) infoPtr->readFile;
if ((infoPtr->watchMask & TCL_READABLE) &&
(WaitForRead(infoPtr, 0) >= 0)) {
@@ -455,8 +451,8 @@ PipeCheckProc(
*
* TclWinMakeFile --
*
- * This function constructs a new TclFile from a given data and
- * type value.
+ * This function constructs a new TclFile from a given data and type
+ * value.
*
* Results:
* Returns a newly allocated WinFile as a TclFile.
@@ -485,15 +481,14 @@ TclWinMakeFile(
*
* TempFileName --
*
- * Gets a temporary file name and deals with the fact that the
- * temporary file path provided by Windows may not actually exist
- * if the TMP or TEMP environment variables refer to a
- * non-existent directory.
+ * Gets a temporary file name and deals with the fact that the temporary
+ * file path provided by Windows may not actually exist if the TMP or
+ * TEMP environment variables refer to a non-existent directory.
*
- * Results:
- * 0 if error, non-zero otherwise. If non-zero is returned, the
- * name buffer will be filled with a name that can be used to
- * construct a temporary file.
+ * Results:
+ * 0 if error, non-zero otherwise. If non-zero is returned, the name
+ * buffer will be filled with a name that can be used to construct a
+ * temporary file.
*
* Side effects:
* None.
@@ -503,14 +498,14 @@ TclWinMakeFile(
static int
TempFileName(name)
- WCHAR name[MAX_PATH]; /* Buffer in which name for temporary
- * file gets stored. */
+ WCHAR name[MAX_PATH]; /* Buffer in which name for temporary file
+ * gets stored. */
{
TCHAR *prefix;
prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL";
if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) {
- if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
+ if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
name) != 0) {
return 1;
}
@@ -522,7 +517,7 @@ TempFileName(name)
((char *) name)[0] = '.';
((char *) name)[1] = '\0';
}
- return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
+ return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
name);
}
@@ -549,7 +544,7 @@ TclpMakeFile(channel, direction)
{
HANDLE handle;
- if (Tcl_GetChannelHandle(channel, direction,
+ if (Tcl_GetChannelHandle(channel, direction,
(ClientData *) &handle) == TCL_OK) {
return TclWinMakeFile(handle);
} else {
@@ -565,8 +560,8 @@ TclpMakeFile(channel, direction)
* This function opens files for use in a pipeline.
*
* Results:
- * Returns a newly allocated TclFile structure containing the
- * file handle.
+ * Returns a newly allocated TclFile structure containing the file
+ * handle.
*
* Side effects:
* None.
@@ -583,24 +578,24 @@ TclpOpenFile(path, mode)
DWORD accessMode, createMode, shareMode, flags;
Tcl_DString ds;
CONST TCHAR *nativePath;
-
+
/*
* Map the access bits to the NT access mode.
*/
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
- case O_RDONLY:
- accessMode = GENERIC_READ;
- break;
- case O_WRONLY:
- accessMode = GENERIC_WRITE;
- break;
- case O_RDWR:
- accessMode = (GENERIC_READ | GENERIC_WRITE);
- break;
- default:
- TclWinConvertError(ERROR_INVALID_FUNCTION);
- return NULL;
+ case O_RDONLY:
+ accessMode = GENERIC_READ;
+ break;
+ case O_WRONLY:
+ accessMode = GENERIC_WRITE;
+ break;
+ case O_RDWR:
+ accessMode = (GENERIC_READ | GENERIC_WRITE);
+ break;
+ default:
+ TclWinConvertError(ERROR_INVALID_FUNCTION);
+ return NULL;
}
/*
@@ -608,23 +603,23 @@ TclpOpenFile(path, mode)
*/
switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) {
- case (O_CREAT | O_EXCL):
- case (O_CREAT | O_EXCL | O_TRUNC):
- createMode = CREATE_NEW;
- break;
- case (O_CREAT | O_TRUNC):
- createMode = CREATE_ALWAYS;
- break;
- case O_CREAT:
- createMode = OPEN_ALWAYS;
- break;
- case O_TRUNC:
- case (O_TRUNC | O_EXCL):
- createMode = TRUNCATE_EXISTING;
- break;
- default:
- createMode = OPEN_EXISTING;
- break;
+ case (O_CREAT | O_EXCL):
+ case (O_CREAT | O_EXCL | O_TRUNC):
+ createMode = CREATE_NEW;
+ break;
+ case (O_CREAT | O_TRUNC):
+ createMode = CREATE_ALWAYS;
+ break;
+ case O_CREAT:
+ createMode = OPEN_ALWAYS;
+ break;
+ case O_TRUNC:
+ case (O_TRUNC | O_EXCL):
+ createMode = TRUNCATE_EXISTING;
+ break;
+ default:
+ createMode = OPEN_EXISTING;
+ break;
}
nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
@@ -651,19 +646,19 @@ TclpOpenFile(path, mode)
* Now we get to create the file.
*/
- handle = (*tclWinProcs->createFileProc)(nativePath, accessMode,
+ handle = (*tclWinProcs->createFileProc)(nativePath, accessMode,
shareMode, NULL, createMode, flags, NULL);
Tcl_DStringFree(&ds);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err;
-
+
err = GetLastError();
if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
}
- TclWinConvertError(err);
- return NULL;
+ TclWinConvertError(err);
+ return NULL;
}
/*
@@ -682,9 +677,9 @@ TclpOpenFile(path, mode)
*
* TclpCreateTempFile --
*
- * This function opens a unique file with the property that it
- * will be deleted when its file handle is closed. The temporary
- * file is created in the system temporary directory.
+ * This function opens a unique file with the property that it will be
+ * deleted when its file handle is closed. The temporary file is created
+ * in the system temporary directory.
*
* Results:
* Returns a valid TclFile, or NULL on failure.
@@ -708,8 +703,8 @@ TclpCreateTempFile(contents)
return NULL;
}
- handle = (*tclWinProcs->createFileProc)((TCHAR *) name,
- GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS,
+ handle = (*tclWinProcs->createFileProc)((TCHAR *) name,
+ GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS,
FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL);
if (handle == INVALID_HANDLE_VALUE) {
goto error;
@@ -726,8 +721,9 @@ TclpCreateTempFile(contents)
/*
* Convert the contents from UTF to native encoding
*/
+
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
-
+
for (p = native; *p != '\0'; p++) {
if (*p == '\n') {
length = p - native;
@@ -757,7 +753,10 @@ TclpCreateTempFile(contents)
return TclWinMakeFile(handle);
error:
- /* Free the native representation of the contents if necessary */
+ /*
+ * Free the native representation of the contents if necessary.
+ */
+
if (contents != NULL) {
Tcl_DStringFree(&dstring);
}
@@ -784,7 +783,7 @@ TclpCreateTempFile(contents)
*----------------------------------------------------------------------
*/
-Tcl_Obj*
+Tcl_Obj*
TclpTempFileName()
{
WCHAR fileName[MAX_PATH];
@@ -801,23 +800,23 @@ TclpTempFileName()
*
* TclpCreatePipe --
*
- * Creates an anonymous pipe.
+ * Creates an anonymous pipe.
*
* Results:
- * Returns 1 on success, 0 on failure.
+ * Returns 1 on success, 0 on failure.
*
* Side effects:
- * Creates a pipe.
+ * Creates a pipe.
*
*----------------------------------------------------------------------
*/
int
TclpCreatePipe(
- TclFile *readPipe, /* Location to store file handle for
- * read side of pipe. */
- TclFile *writePipe) /* Location to store file handle for
- * write side of pipe. */
+ TclFile *readPipe, /* Location to store file handle for read side
+ * of pipe. */
+ TclFile *writePipe) /* Location to store file handle for write
+ * side of pipe. */
{
HANDLE readHandle, writeHandle;
@@ -836,7 +835,7 @@ TclpCreatePipe(
*
* TclpCloseFile --
*
- * Closes a pipeline file handle. These handles are created by
+ * Closes a pipeline file handle. These handles are created by
* TclpOpenFile, TclpCreatePipe, or TclpMakeFile.
*
* Results:
@@ -850,33 +849,33 @@ TclpCreatePipe(
int
TclpCloseFile(
- TclFile file) /* The file to close. */
+ TclFile file) /* The file to close. */
{
WinFile *filePtr = (WinFile *) file;
switch (filePtr->type) {
- case WIN_FILE:
- /*
- * Don't close the Win32 handle if the handle is a standard channel
- * during the thread exit process. Otherwise, one thread may kill
- * the stdio of another.
- */
+ case WIN_FILE:
+ /*
+ * Don't close the Win32 handle if the handle is a standard channel
+ * during the thread exit process. Otherwise, one thread may kill the
+ * stdio of another.
+ */
- if (!TclInThreadExit()
- || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
- && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
- && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
- if (filePtr->handle != NULL &&
- CloseHandle(filePtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
- ckfree((char *) filePtr);
- return -1;
- }
+ if (!TclInThreadExit()
+ || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
+ && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
+ && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
+ if (filePtr->handle != NULL &&
+ CloseHandle(filePtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ ckfree((char *) filePtr);
+ return -1;
}
- break;
+ }
+ break;
- default:
- Tcl_Panic("TclpCloseFile: unexpected file type");
+ default:
+ Tcl_Panic("TclpCloseFile: unexpected file type");
}
ckfree((char *) filePtr);
@@ -892,9 +891,9 @@ TclpCloseFile(
* child process.
*
* Results:
- * Returns the process id for the child process. If the pid was not
- * known by Tcl, either because the pid was not created by Tcl or the
- * child process has already been reaped, -1 is returned.
+ * Returns the process id for the child process. If the pid was not known
+ * by Tcl, either because the pid was not created by Tcl or the child
+ * process has already been reaped, -1 is returned.
*
* Side effects:
* None.
@@ -926,25 +925,25 @@ TclpGetPid(
*
* TclpCreateProcess --
*
- * Create a child process that has the specified files as its
- * standard input, output, and error. The child process runs
- * asynchronously under Windows NT and Windows 9x, and runs
- * with the same environment variables as the creating process.
+ * Create a child process that has the specified files as its standard
+ * input, output, and error. The child process runs asynchronously under
+ * Windows NT and Windows 9x, and runs with the same environment
+ * variables as the creating process.
*
- * The complete Windows search path is searched to find the specified
- * executable. If an executable by the given name is not found,
- * automatically tries appending ".com", ".exe", and ".bat" to the
+ * The complete Windows search path is searched to find the specified
+ * executable. If an executable by the given name is not found,
+ * automatically tries appending ".com", ".exe", and ".bat" to the
* executable name.
*
* Results:
- * The return value is TCL_ERROR and an error message is left in
- * the interp's result if there was a problem creating the child
- * process. Otherwise, the return value is TCL_OK and *pidPtr is
- * filled with the process id of the child process.
- *
+ * The return value is TCL_ERROR and an error message is left in the
+ * interp's result if there was a problem creating the child process.
+ * Otherwise, the return value is TCL_OK and *pidPtr is filled with the
+ * process id of the child process.
+ *
* Side effects:
* A process is created.
- *
+ *
*----------------------------------------------------------------------
*/
@@ -955,27 +954,27 @@ TclpCreateProcess(
* Error messages from the child process
* itself are sent to errorFile. */
int argc, /* Number of arguments in following array. */
- CONST char **argv, /* Array of argument strings. argv[0]
- * contains the name of the executable
- * converted to native format (using the
- * Tcl_TranslateFileName call). Additional
+ CONST char **argv, /* Array of argument strings. argv[0] contains
+ * the name of the executable converted to
+ * native format (using the
+ * Tcl_TranslateFileName call). Additional
* arguments have not been converted. */
- TclFile inputFile, /* If non-NULL, gives the file to use as
- * input for the child process. If inputFile
- * file is not readable or is NULL, the child
- * will receive no standard input. */
- TclFile outputFile, /* If non-NULL, gives the file that
- * receives output from the child process. If
+ TclFile inputFile, /* If non-NULL, gives the file to use as input
+ * for the child process. If inputFile file is
+ * not readable or is NULL, the child will
+ * receive no standard input. */
+ TclFile outputFile, /* If non-NULL, gives the file that receives
+ * output from the child process. If
* outputFile file is not writeable or is
* NULL, output from the child will be
* discarded. */
- TclFile errorFile, /* If non-NULL, gives the file that
- * receives errors from the child process. If
- * errorFile file is not writeable or is NULL,
- * errors from the child will be discarded.
- * errorFile may be the same as outputFile. */
- Tcl_Pid *pidPtr) /* If this procedure is successful, pidPtr
- * is filled with the process id of the child
+ TclFile errorFile, /* If non-NULL, gives the file that receives
+ * errors from the child process. If errorFile
+ * file is not writeable or is NULL, errors
+ * from the child will be discarded. errorFile
+ * may be the same as outputFile. */
+ Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
+ * filled with the process id of the child
* process. */
{
int result, applType, createFlags;
@@ -1000,13 +999,13 @@ TclpCreateProcess(
/*
* STARTF_USESTDHANDLES must be used to pass handles to child process.
- * Using SetStdHandle() and/or dup2() only works when a console mode
+ * Using SetStdHandle() and/or dup2() only works when a console mode
* parent process is spawning an attached console mode child process.
*/
ZeroMemory(&startInfo, sizeof(startInfo));
startInfo.cb = sizeof(startInfo);
- startInfo.dwFlags = STARTF_USESTDHANDLES;
+ startInfo.dwFlags = STARTF_USESTDHANDLES;
startInfo.hStdInput = INVALID_HANDLE_VALUE;
startInfo.hStdOutput= INVALID_HANDLE_VALUE;
startInfo.hStdError = INVALID_HANDLE_VALUE;
@@ -1016,8 +1015,8 @@ TclpCreateProcess(
secAtts.bInheritHandle = TRUE;
/*
- * We have to check the type of each file, since we cannot duplicate
- * some file types.
+ * We have to check the type of each file, since we cannot duplicate some
+ * file types.
*/
inputHandle = INVALID_HANDLE_VALUE;
@@ -1043,23 +1042,22 @@ TclpCreateProcess(
}
/*
- * Duplicate all the handles which will be passed off as stdin, stdout
- * and stderr of the child process. The duplicate handles are set to
- * be inheritable, so the child process can use them.
+ * Duplicate all the handles which will be passed off as stdin, stdout and
+ * stderr of the child process. The duplicate handles are set to be
+ * inheritable, so the child process can use them.
*/
if (inputHandle == INVALID_HANDLE_VALUE) {
- /*
- * If handle was not set, stdin should return immediate EOF.
- * Under Windows95, some applications (both 16 and 32 bit!)
- * cannot read from the NUL device; they read from console
- * instead. When running tk, this is fatal because the child
- * process would hang forever waiting for EOF from the unmapped
- * console window used by the helper application.
+ /*
+ * If handle was not set, stdin should return immediate EOF. Under
+ * Windows95, some applications (both 16 and 32 bit!) cannot read from
+ * the NUL device; they read from console instead. When running tk,
+ * this is fatal because the child process would hang forever waiting
+ * for EOF from the unmapped console window used by the helper
+ * application.
*
- * Fortunately, the helper application detects a closed pipe
- * as an immediate EOF and can pass that information to the
- * child process.
+ * Fortunately, the helper application detects a closed pipe as an
+ * immediate EOF and can pass that information to the child process.
*/
if (CreatePipe(&startInfo.hStdInput, &h, &secAtts, 0) != FALSE) {
@@ -1078,21 +1076,20 @@ TclpCreateProcess(
if (outputHandle == INVALID_HANDLE_VALUE) {
/*
- * If handle was not set, output should be sent to an infinitely
- * deep sink. Under Windows 95, some 16 bit applications cannot
- * have stdout redirected to NUL; they send their output to
- * the console instead. Some applications, like "more" or "dir /p",
- * when outputting multiple pages to the console, also then try and
- * read from the console to go the next page. When running tk, this
- * is fatal because the child process would hang forever waiting
- * for input from the unmapped console window used by the helper
- * application.
+ * If handle was not set, output should be sent to an infinitely deep
+ * sink. Under Windows 95, some 16 bit applications cannot have stdout
+ * redirected to NUL; they send their output to the console instead.
+ * Some applications, like "more" or "dir /p", when outputting
+ * multiple pages to the console, also then try and read from the
+ * console to go the next page. When running tk, this is fatal because
+ * the child process would hang forever waiting for input from the
+ * unmapped console window used by the helper application.
*
- * Fortunately, the helper application will detect a closed pipe
- * as a sink.
+ * Fortunately, the helper application will detect a closed pipe as a
+ * sink.
*/
- if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS)
+ if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS)
&& (applType == APPL_DOS)) {
if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) {
CloseHandle(h);
@@ -1102,8 +1099,8 @@ TclpCreateProcess(
&secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
}
} else {
- DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput,
- 0, TRUE, DUPLICATE_SAME_ACCESS);
+ DuplicateHandle(hProcess, outputHandle, hProcess,
+ &startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
@@ -1114,35 +1111,34 @@ TclpCreateProcess(
if (errorHandle == INVALID_HANDLE_VALUE) {
/*
- * If handle was not set, errors should be sent to an infinitely
- * deep sink.
+ * If handle was not set, errors should be sent to an infinitely deep
+ * sink.
*/
startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
- DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError,
+ DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError,
0, TRUE, DUPLICATE_SAME_ACCESS);
- }
+ }
if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
Tcl_AppendResult(interp, "couldn't duplicate error handle: ",
Tcl_PosixError(interp), (char *) NULL);
goto end;
}
- /*
- * If we do not have a console window, then we must run DOS and
- * WIN32 console mode applications as detached processes. This tells
- * the loader that the child application should not inherit the
- * console, and that it should not create a new console window for
- * the child application. The child application should get its stdio
- * from the redirection handles provided by this application, and run
- * in the background.
+
+ /*
+ * If we do not have a console window, then we must run DOS and WIN32
+ * console mode applications as detached processes. This tells the loader
+ * that the child application should not inherit the console, and that it
+ * should not create a new console window for the child application. The
+ * child application should get its stdio from the redirection handles
+ * provided by this application, and run in the background.
*
- * If we are starting a GUI process, they don't automatically get a
+ * If we are starting a GUI process, they don't automatically get a
* console, so it doesn't matter if they are started as foreground or
- * detached processes. The GUI window will still pop up to the
- * foreground.
+ * detached processes. The GUI window will still pop up to the foreground.
*/
if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
@@ -1150,11 +1146,11 @@ TclpCreateProcess(
createFlags = 0;
} else if (applType == APPL_DOS) {
/*
- * Under NT, 16-bit DOS applications will not run unless they
- * can be attached to a console. If we are running without a
- * console, run the 16-bit program as an normal process inside
- * of a hidden console application, and then run that hidden
- * console as a detached process.
+ * Under NT, 16-bit DOS applications will not run unless they can
+ * be attached to a console. If we are running without a console,
+ * run the 16-bit program as an normal process inside of a hidden
+ * console application, and then run that hidden console as a
+ * detached process.
*/
startInfo.wShowWindow = SW_HIDE;
@@ -1163,41 +1159,41 @@ TclpCreateProcess(
Tcl_DStringAppend(&cmdLine, "cmd.exe /c", -1);
} else {
createFlags = DETACHED_PROCESS;
- }
+ }
} else {
if (HasConsole()) {
createFlags = 0;
} else {
createFlags = DETACHED_PROCESS;
}
-
+
if (applType == APPL_DOS) {
/*
- * Under Windows 95, 16-bit DOS applications do not work well
- * with pipes:
+ * Under Windows 95, 16-bit DOS applications do not work well with
+ * pipes:
*
- * 1. EOF on a pipe between a detached 16-bit DOS application
- * and another application is not seen at the other
- * end of the pipe, so the listening process blocks forever on
- * reads. This inablity to detect EOF happens when either a
- * 16-bit app or the 32-bit app is the listener.
+ * 1. EOF on a pipe between a detached 16-bit DOS application and
+ * another application is not seen at the other end of the pipe,
+ * so the listening process blocks forever on reads. This inablity
+ * to detect EOF happens when either a 16-bit app or the 32-bit
+ * app is the listener.
*
- * 2. If a 16-bit DOS application (detached or not) blocks when
+ * 2. If a 16-bit DOS application (detached or not) blocks when
* writing to a pipe, it will never wake up again, and it
* eventually brings the whole system down around it.
*
- * The 16-bit application is run as a normal process inside
- * of a hidden helper console app, and this helper may be run
- * as a detached process. If any of the stdio handles is
- * a pipe, the helper application accumulates information
- * into temp files and forwards it to or from the DOS
- * application as appropriate. This means that DOS apps
- * must receive EOF from a stdin pipe before they will actually
- * begin, and must finish generating stdout or stderr before
- * the data will be sent to the next stage of the pipe.
+ * The 16-bit application is run as a normal process inside of a
+ * hidden helper console app, and this helper may be run as a
+ * detached process. If any of the stdio handles is a pipe, the
+ * helper application accumulates information into temp files and
+ * forwards it to or from the DOS application as appropriate.
+ * This means that DOS apps must receive EOF from a stdin pipe
+ * before they will actually begin, and must finish generating
+ * stdout or stderr before the data will be sent to the next stage
+ * of the pipe.
*
- * The helper app should be located in the same directory as
- * the tcl dll.
+ * The helper app should be located in the same directory as the
+ * tcl dll.
*/
if (createFlags != 0) {
@@ -1211,13 +1207,14 @@ TclpCreateProcess(
int i, fileExists;
char *start,*end;
Tcl_DString pipeDll;
+
Tcl_DStringInit(&pipeDll);
Tcl_DStringAppend(&pipeDll, TCL_PIPE_DLL, -1);
tclExePtr = TclGetObjNameOfExecutable();
start = Tcl_GetStringFromObj(tclExePtr, &i);
for (end = start + (i-1); end > start; end--) {
if (*end == '/') {
- break;
+ break;
}
}
if (*end != '/') {
@@ -1233,7 +1230,7 @@ TclpCreateProcess(
fileExists = (Tcl_FSAccess(pipeDllPtr, F_OK) == 0);
if (!fileExists) {
Tcl_Panic("Tcl pipe dll \"%s\" not found",
- Tcl_DStringValue(&pipeDll));
+ Tcl_DStringValue(&pipeDll));
}
Tcl_DStringAppend(&cmdLine, Tcl_DStringValue(&pipeDll), -1);
Tcl_DecrRefCount(tclExePtr);
@@ -1242,30 +1239,29 @@ TclpCreateProcess(
}
}
}
-
+
/*
* cmdLine gets the full command line used to invoke the executable,
- * including the name of the executable itself. The command line
- * arguments in argv[] are stored in cmdLine separated by spaces.
- * Special characters in individual arguments from argv[] must be
- * quoted when being stored in cmdLine.
+ * including the name of the executable itself. The command line arguments
+ * in argv[] are stored in cmdLine separated by spaces. Special characters
+ * in individual arguments from argv[] must be quoted when being stored in
+ * cmdLine.
*
- * When calling any application, bear in mind that arguments that
- * specify a path name are not converted. If an argument contains
- * forward slashes as path separators, it may or may not be
- * recognized as a path name, depending on the program. In general,
- * most applications accept forward slashes only as option
- * delimiters and backslashes only as paths.
+ * When calling any application, bear in mind that arguments that specify
+ * a path name are not converted. If an argument contains forward slashes
+ * as path separators, it may or may not be recognized as a path name,
+ * depending on the program. In general, most applications accept forward
+ * slashes only as option delimiters and backslashes only as paths.
*
- * Additionally, when calling a 16-bit dos or windows application,
- * all path names must use the short, cryptic, path format (e.g.,
- * using ab~1.def instead of "a b.default").
+ * Additionally, when calling a 16-bit dos or windows application, all
+ * path names must use the short, cryptic, path format (e.g., using
+ * ab~1.def instead of "a b.default").
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
- if ((*tclWinProcs->createProcessProc)(NULL,
- (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
+ if ((*tclWinProcs->createProcessProc)(NULL,
+ (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
(DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) {
TclWinConvertError(GetLastError());
Tcl_AppendResult(interp, "couldn't execute \"", argv[0],
@@ -1274,21 +1270,20 @@ TclpCreateProcess(
}
/*
- * This wait is used to force the OS to give some time to the DOS
- * process.
+ * This wait is used to force the OS to give some time to the DOS process.
*/
if (applType == APPL_DOS) {
WaitForSingleObject(procInfo.hProcess, 50);
}
- /*
- * "When an application spawns a process repeatedly, a new thread
- * instance will be created for each process but the previous
- * instances may not be cleaned up. This results in a significant
- * virtual memory loss each time the process is spawned. If there
- * is a WaitForInputIdle() call between CreateProcess() and
- * CloseHandle(), the problem does not occur." PSS ID Number: Q124121
+ /*
+ * "When an application spawns a process repeatedly, a new thread instance
+ * will be created for each process but the previous instances may not be
+ * cleaned up. This results in a significant virtual memory loss each time
+ * the process is spawned. If there is a WaitForInputIdle() call between
+ * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID
+ * Number: Q124121
*/
WaitForInputIdle(procInfo.hProcess, 5000);
@@ -1300,13 +1295,13 @@ TclpCreateProcess(
}
result = TCL_OK;
- end:
+ end:
Tcl_DStringFree(&cmdLine);
if (startInfo.hStdInput != INVALID_HANDLE_VALUE) {
- CloseHandle(startInfo.hStdInput);
+ CloseHandle(startInfo.hStdInput);
}
if (startInfo.hStdOutput != INVALID_HANDLE_VALUE) {
- CloseHandle(startInfo.hStdOutput);
+ CloseHandle(startInfo.hStdOutput);
}
if (startInfo.hStdError != INVALID_HANDLE_VALUE) {
CloseHandle(startInfo.hStdError);
@@ -1320,8 +1315,7 @@ TclpCreateProcess(
*
* HasConsole --
*
- * Determines whether the current application is attached to a
- * console.
+ * Determines whether the current application is attached to a console.
*
* Results:
* Returns TRUE if this application has a console, else FALSE.
@@ -1336,15 +1330,15 @@ static BOOL
HasConsole()
{
HANDLE handle;
-
+
handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE,
NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
if (handle != INVALID_HANDLE_VALUE) {
- CloseHandle(handle);
+ CloseHandle(handle);
return TRUE;
} else {
- return FALSE;
+ return FALSE;
}
}
@@ -1354,29 +1348,28 @@ HasConsole()
* ApplicationType --
*
* Search for the specified program and identify if it refers to a DOS,
- * Windows 3.X, or Win32 program. Used to determine how to invoke
- * a program, or if it can even be invoked.
- *
- * It is possible to almost positively identify DOS and Windows
- * applications that contain the appropriate magic numbers. However,
- * DOS .com files do not seem to contain a magic number; if the program
- * name ends with .com and could not be identified as a Windows .com
- * file, it will be assumed to be a DOS application, even if it was
- * just random data. If the program name does not end with .com, no
- * such assumption is made.
- *
- * The Win32 procedure GetBinaryType incorrectly identifies any
- * junk file that ends with .exe as a dos executable and some
- * executables that don't end with .exe as not executable. Plus it
- * doesn't exist under win95, so I won't feel bad about reimplementing
- * functionality.
+ * Windows 3.X, or Win32 program. Used to determine how to invoke a
+ * program, or if it can even be invoked.
+ *
+ * It is possible to almost positively identify DOS and Windows
+ * applications that contain the appropriate magic numbers. However, DOS
+ * .com files do not seem to contain a magic number; if the program name
+ * ends with .com and could not be identified as a Windows .com file, it
+ * will be assumed to be a DOS application, even if it was just random
+ * data. If the program name does not end with .com, no such assumption
+ * is made.
+ *
+ * The Win32 function GetBinaryType incorrectly identifies any junk file
+ * that ends with .exe as a dos executable and some executables that
+ * don't end with .exe as not executable. Plus it doesn't exist under
+ * win95, so I won't feel bad about reimplementing functionality.
*
* Results:
- * The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32
- * if the filename referred to the corresponding application type.
- * If the file name could not be found or did not refer to any known
- * application type, APPL_NONE is returned and an error message is
- * left in interp. .bat files are identified as APPL_DOS.
+ * The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32 if the
+ * filename referred to the corresponding application type. If the file
+ * name could not be found or did not refer to any known application
+ * type, APPL_NONE is returned and an error message is left in interp.
+ * .bat files are identified as APPL_DOS.
*
* Side effects:
* None.
@@ -1388,7 +1381,7 @@ static int
ApplicationType(interp, originalName, fullName)
Tcl_Interp *interp; /* Interp, for error message. */
const char *originalName; /* Name of the application to find. */
- char fullName[]; /* Filled with complete path to
+ char fullName[]; /* Filled with complete path to
* application. */
{
int applType, i, nameLen, found;
@@ -1403,17 +1396,17 @@ ApplicationType(interp, originalName, fullName)
WCHAR nativeFullPath[MAX_PATH];
static char extensions[][5] = {"", ".com", ".exe", ".bat"};
- /* Look for the program as an external program. First try the name
- * as it is, then try adding .com, .exe, and .bat, in that order, to
- * the name, looking for an executable.
+ /*
+ * Look for the program as an external program. First try the name as it
+ * is, then try adding .com, .exe, and .bat, in that order, to the name,
+ * looking for an executable.
*
- * Using the raw SearchPath() procedure doesn't do quite what is
- * necessary. If the name of the executable already contains a '.'
- * character, it will not try appending the specified extension when
- * searching (in other words, SearchPath will not find the program
- * "a.b.exe" if the arguments specified "a.b" and ".exe").
- * So, first look for the file as it is named. Then manually append
- * the extensions, looking for a match.
+ * Using the raw SearchPath() function doesn't do quite what is necessary.
+ * If the name of the executable already contains a '.' character, it will
+ * not try appending the specified extension when searching (in other
+ * words, SearchPath will not find the program "a.b.exe" if the arguments
+ * specified "a.b" and ".exe"). So, first look for the file as it is
+ * named. Then manually append the extensions, looking for a match.
*/
applType = APPL_NONE;
@@ -1424,9 +1417,9 @@ ApplicationType(interp, originalName, fullName)
for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) {
Tcl_DStringSetLength(&nameBuf, nameLen);
Tcl_DStringAppend(&nameBuf, extensions[i], -1);
- nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf),
+ nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf),
Tcl_DStringLength(&nameBuf), &ds);
- found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL,
+ found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL,
MAX_PATH, nativeFullPath, &rest);
Tcl_DStringFree(&ds);
if (found == 0) {
@@ -1434,8 +1427,8 @@ ApplicationType(interp, originalName, fullName)
}
/*
- * Ignore matches on directories or data files, return if identified
- * a known type.
+ * Ignore matches on directories or data files, return if identified a
+ * known type.
*/
attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath);
@@ -1450,9 +1443,9 @@ ApplicationType(interp, originalName, fullName)
applType = APPL_DOS;
break;
}
-
- hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath,
- GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING,
+
+ hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath,
+ GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
continue;
@@ -1461,12 +1454,12 @@ ApplicationType(interp, originalName, fullName)
header.e_magic = 0;
ReadFile(hFile, (void *) &header, sizeof(header), &read, NULL);
if (header.e_magic != IMAGE_DOS_SIGNATURE) {
- /*
- * Doesn't have the magic number for relocatable executables. If
+ /*
+ * Doesn't have the magic number for relocatable executables. If
* filename ends with .com, assume it's a DOS application anyhow.
* Note that we didn't make this assumption at first, because some
* supposed .com files are really 32-bit executables with all the
- * magic numbers and everything.
+ * magic numbers and everything.
*/
CloseHandle(hFile);
@@ -1477,9 +1470,9 @@ ApplicationType(interp, originalName, fullName)
continue;
}
if (header.e_lfarlc != sizeof(header)) {
- /*
+ /*
* All Windows 3.X and Win32 and some DOS programs have this value
- * set here. If it doesn't, assume that since it already had the
+ * set here. If it doesn't, assume that since it already had the
* other magic number it was a DOS application.
*/
@@ -1488,7 +1481,7 @@ ApplicationType(interp, originalName, fullName)
break;
}
- /*
+ /*
* The DWORD at header.e_lfanew points to yet another magic number.
*/
@@ -1503,11 +1496,11 @@ ApplicationType(interp, originalName, fullName)
applType = APPL_WIN32;
} else {
/*
- * Strictly speaking, there should be a test that there
- * is an 'L' and 'E' at buf[0..1], to identify the type as
- * DOS, but of course we ran into a DOS executable that
- * _doesn't_ have the magic number -- specifically, one
- * compiled using the Lahey Fortran90 compiler.
+ * Strictly speaking, there should be a test that there is an 'L'
+ * and 'E' at buf[0..1], to identify the type as DOS, but of
+ * course we ran into a DOS executable that _doesn't_ have the
+ * magic number - specifically, one compiled using the Lahey
+ * Fortran90 compiler.
*/
applType = APPL_DOS;
@@ -1524,14 +1517,14 @@ ApplicationType(interp, originalName, fullName)
}
if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) {
- /*
- * Replace long path name of executable with short path name for
- * 16-bit applications. Otherwise the application may not be able
- * to correctly parse its own command line to separate off the
+ /*
+ * Replace long path name of executable with short path name for
+ * 16-bit applications. Otherwise the application may not be able to
+ * correctly parse its own command line to separate off the
* application name from the arguments.
*/
- (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath,
+ (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath,
nativeFullPath, MAX_PATH);
strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
Tcl_DStringFree(&ds);
@@ -1539,15 +1532,15 @@ ApplicationType(interp, originalName, fullName)
return applType;
}
-/*
+/*
*----------------------------------------------------------------------
*
* BuildCommandLine --
*
- * The command line arguments are stored in linePtr separated
- * by spaces, in a form that CreateProcess() understands. Special
- * characters in individual arguments from argv[] must be quoted
- * when being stored in cmdLine.
+ * The command line arguments are stored in linePtr separated by spaces,
+ * in a form that CreateProcess() understands. Special characters in
+ * individual arguments from argv[] must be quoted when being stored in
+ * cmdLine.
*
* Results:
* None.
@@ -1560,8 +1553,8 @@ ApplicationType(interp, originalName, fullName)
static void
BuildCommandLine(
- CONST char *executable, /* Full path of executable (including
- * extension). Replacement for argv[0]. */
+ CONST char *executable, /* Full path of executable (including
+ * extension). Replacement for argv[0]. */
int argc, /* Number of arguments. */
CONST char **argv, /* Argument strings in UTF. */
Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the
@@ -1574,8 +1567,7 @@ BuildCommandLine(
Tcl_DStringInit(&ds);
/*
- * Prime the path. Add a space separator if we were primed with
- * something.
+ * Prime the path. Add a space separator if we were primed with something.
*/
Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1);
@@ -1598,7 +1590,7 @@ BuildCommandLine(
int count;
Tcl_UniChar ch;
for (start = arg; *start != '\0'; start += count) {
- count = Tcl_UtfToUniChar(start, &ch);
+ count = Tcl_UtfToUniChar(start, &ch);
if (Tcl_UniCharIsSpace(ch)) { /* INTL: ISO space. */
quote = 1;
break;
@@ -1608,7 +1600,7 @@ BuildCommandLine(
if (quote) {
Tcl_DStringAppend(&ds, "\"", 1);
}
- start = arg;
+ start = arg;
for (special = arg; ; ) {
if ((*special == '\\') && (special[1] == '\\' ||
special[1] == '"' || (quote && special[1] == '\0'))) {
@@ -1617,9 +1609,9 @@ BuildCommandLine(
while (1) {
special++;
if (*special == '"' || (quote && *special == '\0')) {
- /*
- * N backslashes followed a quote -> insert
- * N * 2 + 1 backslashes then a quote.
+ /*
+ * N backslashes followed a quote -> insert N * 2 + 1
+ * backslashes then a quote.
*/
Tcl_DStringAppend(&ds, start,
@@ -1658,9 +1650,8 @@ BuildCommandLine(
*
* TclpCreateCommandChannel --
*
- * This function is called by Tcl_OpenCommandChannel to perform
- * the platform specific channel initialization for a command
- * channel.
+ * This function is called by Tcl_OpenCommandChannel to perform the
+ * platform specific channel initialization for a command channel.
*
* Results:
* Returns a new channel or NULL on failure.
@@ -1701,8 +1692,7 @@ TclpCreateCommandChannel(
infoPtr->channel = (Tcl_Channel) NULL;
/*
- * Use one of the fds associated with the channel as the
- * channel id.
+ * Use one of the fds associated with the channel as the channel id.
*/
if (readFile) {
@@ -1729,8 +1719,8 @@ TclpCreateCommandChannel(
infoPtr->stopReader = CreateEvent(NULL, TRUE, FALSE, NULL);
infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
infoPtr, 0, &id);
- SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
- infoPtr->validMask |= TCL_READABLE;
+ SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
+ infoPtr->validMask |= TCL_READABLE;
} else {
infoPtr->readThread = 0;
}
@@ -1744,26 +1734,25 @@ TclpCreateCommandChannel(
infoPtr->stopWriter = CreateEvent(NULL, TRUE, FALSE, NULL);
infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
infoPtr, 0, &id);
- SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
- infoPtr->validMask |= TCL_WRITABLE;
+ SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
+ infoPtr->validMask |= TCL_WRITABLE;
}
/*
- * For backward compatibility with previous versions of Tcl, we
- * use "file%d" as the base name for pipes even though it would
- * be more natural to use "pipe%d".
- * Use the pointer to keep the channel names unique, in case
- * channels share handles (stdin/stdout).
+ * For backward compatibility with previous versions of Tcl, we use
+ * "file%d" as the base name for pipes even though it would be more
+ * natural to use "pipe%d". Use the pointer to keep the channel names
+ * unique, in case channels share handles (stdin/stdout).
*/
wsprintfA(channelName, "file%lx", infoPtr);
infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
- (ClientData) infoPtr, infoPtr->validMask);
+ (ClientData) infoPtr, infoPtr->validMask);
/*
* Pipes have AUTO translation mode on Windows and ^Z eof char, which
- * means that a ^Z will be appended to them at close. This is needed
- * for Windows programs that expect a ^Z at EOF.
+ * means that a ^Z will be appended to them at close. This is needed for
+ * Windows programs that expect a ^Z at EOF.
*/
Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel,
@@ -1778,8 +1767,8 @@ TclpCreateCommandChannel(
*
* TclGetAndDetachPids --
*
- * Stores a list of the command PIDs for a command channel in
- * the interp's result.
+ * Stores a list of the command PIDs for a command channel in the
+ * interp's result.
*
* Results:
* None.
@@ -1806,18 +1795,18 @@ TclGetAndDetachPids(
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
- return;
+ return;
}
pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
for (i = 0; i < pipePtr->numPids; i++) {
- wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
- Tcl_AppendElement(interp, buf);
- Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
+ wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
+ Tcl_AppendElement(interp, buf);
+ Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
}
if (pipePtr->numPids > 0) {
- ckfree((char *) pipePtr->pidPtr);
- pipePtr->numPids = 0;
+ ckfree((char *) pipePtr->pidPtr);
+ pipePtr->numPids = 0;
}
}
@@ -1841,10 +1830,10 @@ static int
PipeBlockModeProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
+ * TCL_MODE_NONBLOCKING. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
-
+
/*
* Pipes on Windows can not be switched between blocking and nonblocking,
* hence we have to emulate the behavior. This is done in the input
@@ -1892,27 +1881,26 @@ PipeClose2Proc(
errorCode = 0;
result = 0;
- if ((!flags || flags == TCL_CLOSE_READ)
- && (pipePtr->readFile != NULL)) {
+ if ((!flags || flags == TCL_CLOSE_READ) && (pipePtr->readFile != NULL)) {
/*
- * Clean up the background thread if necessary. Note that this
- * must be done before we can close the file, since the
- * thread may be blocking trying to read from the pipe.
+ * Clean up the background thread if necessary. Note that this must be
+ * done before we can close the file, since the thread may be blocking
+ * trying to read from the pipe.
*/
if (pipePtr->readThread) {
/*
- * The thread may already have closed on its own. Check
- * its exit code.
+ * The thread may already have closed on its own. Check its exit
+ * code.
*/
GetExitCodeThread(pipePtr->readThread, &exitCode);
if (exitCode == STILL_ACTIVE) {
/*
- * Set the stop event so that if the reader thread is
- * blocked in PipeReaderThread on WaitForMultipleEvents,
- * it will exit cleanly.
+ * Set the stop event so that if the reader thread is blocked
+ * in PipeReaderThread on WaitForMultipleEvents, it will exit
+ * cleanly.
*/
SetEvent(pipePtr->stopReader);
@@ -1926,18 +1914,16 @@ PipeClose2Proc(
20) == WAIT_TIMEOUT) {
/*
* The thread must be blocked waiting for the pipe to
- * become readable in ReadFile(). There isn't a
- * clean way to exit the thread from this condition.
- * We should terminate the child process instead to
- * get the reader thread to fall out of ReadFile with
- * a FALSE. (below) is not the correct way to do
- * this, but will stay here until a better solution
- * is found.
+ * become readable in ReadFile(). There isn't a clean way
+ * to exit the thread from this condition. We should
+ * terminate the child process instead to get the reader
+ * thread to fall out of ReadFile with a FALSE. (below) is
+ * not the correct way to do this, but will stay here
+ * until a better solution is found.
*
* Note that we need to guard against terminating the
- * thread while it is in the middle of
- * Tcl_ThreadAlert because it won't be able to
- * release the notifier lock.
+ * thread while it is in the middle of Tcl_ThreadAlert
+ * because it won't be able to release the notifier lock.
*/
Tcl_MutexLock(&pipeMutex);
@@ -1964,26 +1950,25 @@ PipeClose2Proc(
&& (pipePtr->writeFile != NULL)) {
if (pipePtr->writeThread) {
/*
- * Wait for the writer thread to finish the current buffer,
- * then terminate the thread and close the handles. If the
- * channel is nonblocking, there should be no pending write
- * operations.
+ * Wait for the writer thread to finish the current buffer, then
+ * terminate the thread and close the handles. If the channel is
+ * nonblocking, there should be no pending write operations.
*/
WaitForSingleObject(pipePtr->writable, INFINITE);
/*
- * The thread may already have closed on it's own. Check
- * its exit code.
+ * The thread may already have closed on it's own. Check its exit
+ * code.
*/
GetExitCodeThread(pipePtr->writeThread, &exitCode);
if (exitCode == STILL_ACTIVE) {
/*
- * Set the stop event so that if the reader thread is
- * blocked in PipeReaderThread on WaitForMultipleEvents,
- * it will exit cleanly.
+ * Set the stop event so that if the reader thread is blocked
+ * in PipeReaderThread on WaitForMultipleEvents, it will exit
+ * cleanly.
*/
SetEvent(pipePtr->stopWriter);
@@ -1997,18 +1982,16 @@ PipeClose2Proc(
20) == WAIT_TIMEOUT) {
/*
* The thread must be blocked waiting for the pipe to
- * consume input in WriteFile(). There isn't a clean
- * way to exit the thread from this condition. We
- * should terminate the child process instead to get
- * the writer thread to fall out of WriteFile with a
- * FALSE. (below) is not the correct way to do this,
- * but will stay here until a better solution is
- * found.
+ * consume input in WriteFile(). There isn't a clean way
+ * to exit the thread from this condition. We should
+ * terminate the child process instead to get the writer
+ * thread to fall out of WriteFile with a FALSE. (below)
+ * is not the correct way to do this, but will stay here
+ * until a better solution is found.
*
* Note that we need to guard against terminating the
- * thread while it is in the middle of
- * Tcl_ThreadAlert because it won't be able to
- * release the notifier lock.
+ * thread while it is in the middle of Tcl_ThreadAlert
+ * because it won't be able to release the notifier lock.
*/
Tcl_MutexLock(&pipeMutex);
@@ -2059,9 +2042,9 @@ PipeClose2Proc(
if ((pipePtr->flags & PIPE_ASYNC) || TclInExit()) {
/*
- * If the channel is non-blocking or Tcl is being cleaned up,
- * just detach the children PIDs, reap them (important if we are
- * in a dynamic load module), and discard the errorFile.
+ * If the channel is non-blocking or Tcl is being cleaned up, just
+ * detach the children PIDs, reap them (important if we are in a
+ * dynamic load module), and discard the errorFile.
*/
Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
@@ -2069,7 +2052,7 @@ PipeClose2Proc(
if (pipePtr->errorFile) {
if (TclpCloseFile(pipePtr->errorFile) != 0) {
- if ( errorCode == 0 ) {
+ if (errorCode == 0) {
errorCode = errno;
}
}
@@ -2117,8 +2100,8 @@ PipeClose2Proc(
*
* PipeInputProc --
*
- * Reads input from the IO channel into the buffer given. Returns
- * count of how many bytes were actually read, and an error indication.
+ * Reads input from the IO channel into the buffer given. Returns count
+ * of how many bytes were actually read, and an error indication.
*
* Results:
* A count of how many bytes were read is returned and an error
@@ -2132,11 +2115,11 @@ PipeClose2Proc(
static int
PipeInputProc(
- ClientData instanceData, /* Pipe state. */
- char *buf, /* Where to store data read. */
- int bufSize, /* How much space is available
- * in the buffer? */
- int *errorCode) /* Where to store error code. */
+ ClientData instanceData, /* Pipe state. */
+ char *buf, /* Where to store data read. */
+ int bufSize, /* How much space is available in the
+ * buffer? */
+ int *errorCode) /* Where to store error code. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->readFile;
@@ -2161,8 +2144,8 @@ PipeInputProc(
if (infoPtr->readFlags & PIPE_EXTRABYTE) {
/*
- * The reader thread consumed 1 byte as a side effect of
- * waiting so we need to move it into the buffer.
+ * The reader thread consumed 1 byte as a side effect of waiting so we
+ * need to move it into the buffer.
*/
*buf = infoPtr->extraByte;
@@ -2181,9 +2164,9 @@ PipeInputProc(
}
/*
- * Attempt to read bufSize bytes. The read will return immediately
- * if there is any data available. Otherwise it will block until
- * at least one byte is available or an EOF occurs.
+ * Attempt to read bufSize bytes. The read will return immediately if
+ * there is any data available. Otherwise it will block until at least one
+ * byte is available or an EOF occurs.
*/
if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &count,
@@ -2211,12 +2194,12 @@ PipeInputProc(
*
* PipeOutputProc --
*
- * Writes the given output on the IO channel. Returns count of how
- * many characters were actually written, and an error indication.
+ * Writes the given output on the IO channel. Returns count of how many
+ * characters were actually written, and an error indication.
*
* Results:
- * A count of how many characters were written is returned and an
- * error indication is returned in an output argument.
+ * A count of how many characters were written is returned and an error
+ * indication is returned in an output argument.
*
* Side effects:
* Writes output on the actual channel.
@@ -2226,27 +2209,27 @@ PipeInputProc(
static int
PipeOutputProc(
- ClientData instanceData, /* Pipe state. */
- CONST char *buf, /* The data buffer. */
- int toWrite, /* How many bytes to write? */
- int *errorCode) /* Where to store error code. */
+ ClientData instanceData, /* Pipe state. */
+ CONST char *buf, /* The data buffer. */
+ int toWrite, /* How many bytes to write? */
+ int *errorCode) /* Where to store error code. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->writeFile;
DWORD bytesWritten, timeout;
-
+
*errorCode = 0;
timeout = (infoPtr->flags & PIPE_ASYNC) ? 0 : INFINITE;
if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
/*
- * The writer thread is blocked waiting for a write to complete
- * and the channel is in non-blocking mode.
+ * The writer thread is blocked waiting for a write to complete and
+ * the channel is in non-blocking mode.
*/
errno = EAGAIN;
goto error;
}
-
+
/*
* Check for a background error on the last write.
*/
@@ -2259,8 +2242,8 @@ PipeOutputProc(
if (infoPtr->flags & PIPE_ASYNC) {
/*
- * The pipe is non-blocking, so copy the data into the output
- * buffer and restart the writer thread.
+ * The pipe is non-blocking, so copy the data into the output buffer
+ * and restart the writer thread.
*/
if (toWrite > infoPtr->writeBufLen) {
@@ -2281,8 +2264,8 @@ PipeOutputProc(
bytesWritten = toWrite;
} else {
/*
- * In the blocking case, just try to write the buffer directly.
- * This avoids an unnecessary copy.
+ * In the blocking case, just try to write the buffer directly. This
+ * avoids an unnecessary copy.
*/
if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite,
@@ -2293,7 +2276,7 @@ PipeOutputProc(
}
return bytesWritten;
- error:
+ error:
*errorCode = errno;
return -1;
@@ -2304,15 +2287,15 @@ PipeOutputProc(
*
* PipeEventProc --
*
- * This function is invoked by Tcl_ServiceEvent when a file event
- * reaches the front of the event queue. This procedure invokes
- * Tcl_NotifyChannel on the pipe.
+ * This function is invoked by Tcl_ServiceEvent when a file event reaches
+ * the front of the event queue. This function invokes Tcl_NotifyChannel
+ * on the pipe.
*
* 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_FILE_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_FILE_EVENTS flag bit isn't set.
*
* Side effects:
* Whatever the notifier callback does.
@@ -2338,9 +2321,9 @@ PipeEventProc(
/*
* Search through the list of watched pipes for the one whose handle
- * matches the event. We do this rather than simply dereferencing
- * the handle in the event so that pipes can be deleted while the
- * event is in the queue.
+ * matches the event. We do this rather than simply dereferencing the
+ * handle in the event so that pipes can be deleted while the event is in
+ * the queue.
*/
for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
@@ -2360,9 +2343,9 @@ PipeEventProc(
}
/*
- * Check to see if the pipe is readable. Note
- * that we can't tell if a pipe is writable, so we always report it
- * as being writable unless we have detected EOF.
+ * Check to see if the pipe is readable. Note that we can't tell if a pipe
+ * is writable, so we always report it as being writable unless we have
+ * detected EOF.
*/
filePtr = (WinFile*) ((PipeInfo*)infoPtr)->writeFile;
@@ -2394,8 +2377,7 @@ PipeEventProc(
*
* PipeWatchProc --
*
- * Called by the notifier to set up to watch for events on this
- * channel.
+ * Called by the notifier to set up to watch for events on this channel.
*
* Results:
* None.
@@ -2408,10 +2390,10 @@ PipeEventProc(
static void
PipeWatchProc(
- ClientData instanceData, /* Pipe state. */
- int mask) /* What events to watch for, OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
+ ClientData instanceData, /* Pipe state. */
+ int mask) /* What events to watch for, OR-ed combination
+ * of TCL_READABLE, TCL_WRITABLE and
+ * TCL_EXCEPTION. */
{
PipeInfo **nextPtrPtr, *ptr;
PipeInfo *infoPtr = (PipeInfo *) instanceData;
@@ -2419,9 +2401,8 @@ PipeWatchProc(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * Since most of the work is handled by the background threads,
- * we just need to update the watchMask and then force the notifier
- * to poll once.
+ * Since most of the work is handled by the background threads, we just
+ * need to update the watchMask and then force the notifier to poll once.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
@@ -2439,8 +2420,8 @@ PipeWatchProc(
*/
for (nextPtrPtr = &(tsdPtr->firstPipePtr), ptr = *nextPtrPtr;
- ptr != NULL;
- nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
+ ptr != NULL;
+ nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
if (infoPtr == ptr) {
*nextPtrPtr = ptr->nextPtr;
break;
@@ -2455,12 +2436,12 @@ PipeWatchProc(
*
* PipeGetHandleProc --
*
- * Called from Tcl_GetChannelHandle to retrieve OS handles from
- * inside a command pipeline based channel.
+ * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
+ * command pipeline based channel.
*
* Results:
- * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
- * there is no handle for the specified direction.
+ * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
+ * handle for the specified direction.
*
* Side effects:
* None.
@@ -2475,7 +2456,7 @@ PipeGetHandleProc(
ClientData *handlePtr) /* Where to store the handle. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
- WinFile *filePtr;
+ WinFile *filePtr;
if (direction == TCL_READABLE && infoPtr->readFile) {
filePtr = (WinFile*) infoPtr->readFile;
@@ -2498,13 +2479,12 @@ PipeGetHandleProc(
* Emulates the waitpid system call.
*
* Results:
- * Returns 0 if the process is still alive, -1 on an error, or
- * the pid on a clean close.
+ * Returns 0 if the process is still alive, -1 on an error, or the pid on
+ * a clean close.
*
* Side effects:
- * Unless WNOHANG is set and the wait times out, the process
- * information record will be deleted and the process handle
- * will be closed.
+ * Unless WNOHANG is set and the wait times out, the process information
+ * record will be deleted and the process handle will be closed.
*
*----------------------------------------------------------------------
*/
@@ -2525,7 +2505,7 @@ Tcl_WaitPid(
/*
* If no pid is specified, do nothing.
*/
-
+
if (pid == 0) {
*statPtr = 0;
return 0;
@@ -2550,17 +2530,17 @@ Tcl_WaitPid(
* If the pid is not one of the processes we know about (we started it)
* then do nothing.
*/
-
+
if (infoPtr == NULL) {
- *statPtr = 0;
+ *statPtr = 0;
return 0;
}
/*
- * Officially "wait" for it to finish. We either poll (WNOHANG) or
- * wait for an infinite amount of time.
+ * Officially "wait" for it to finish. We either poll (WNOHANG) or wait
+ * for an infinite amount of time.
*/
-
+
if (options & WNOHANG) {
flags = 0;
} else {
@@ -2573,6 +2553,7 @@ Tcl_WaitPid(
/*
* Re-insert this infoPtr back on the list.
*/
+
Tcl_MutexLock(&pipeMutex);
infoPtr->nextPtr = procList;
procList = infoPtr;
@@ -2589,64 +2570,65 @@ Tcl_WaitPid(
*/
switch (exitCode) {
- case EXCEPTION_FLT_DENORMAL_OPERAND:
- case EXCEPTION_FLT_DIVIDE_BY_ZERO:
- case EXCEPTION_FLT_INEXACT_RESULT:
- case EXCEPTION_FLT_INVALID_OPERATION:
- case EXCEPTION_FLT_OVERFLOW:
- case EXCEPTION_FLT_STACK_CHECK:
- case EXCEPTION_FLT_UNDERFLOW:
- case EXCEPTION_INT_DIVIDE_BY_ZERO:
- case EXCEPTION_INT_OVERFLOW:
- *statPtr = SIGFPE;
- break;
+ case EXCEPTION_FLT_DENORMAL_OPERAND:
+ case EXCEPTION_FLT_DIVIDE_BY_ZERO:
+ case EXCEPTION_FLT_INEXACT_RESULT:
+ case EXCEPTION_FLT_INVALID_OPERATION:
+ case EXCEPTION_FLT_OVERFLOW:
+ case EXCEPTION_FLT_STACK_CHECK:
+ case EXCEPTION_FLT_UNDERFLOW:
+ case EXCEPTION_INT_DIVIDE_BY_ZERO:
+ case EXCEPTION_INT_OVERFLOW:
+ *statPtr = SIGFPE;
+ break;
- case EXCEPTION_PRIV_INSTRUCTION:
- case EXCEPTION_ILLEGAL_INSTRUCTION:
- *statPtr = SIGILL;
- break;
+ case EXCEPTION_PRIV_INSTRUCTION:
+ case EXCEPTION_ILLEGAL_INSTRUCTION:
+ *statPtr = SIGILL;
+ break;
- case EXCEPTION_ACCESS_VIOLATION:
- case EXCEPTION_ARRAY_BOUNDS_EXCEEDED:
- case EXCEPTION_STACK_OVERFLOW:
- case EXCEPTION_NONCONTINUABLE_EXCEPTION:
- case EXCEPTION_INVALID_DISPOSITION:
- case EXCEPTION_GUARD_PAGE:
- case EXCEPTION_INVALID_HANDLE:
- *statPtr = SIGSEGV;
- break;
+ case EXCEPTION_ACCESS_VIOLATION:
+ case EXCEPTION_ARRAY_BOUNDS_EXCEEDED:
+ case EXCEPTION_STACK_OVERFLOW:
+ case EXCEPTION_NONCONTINUABLE_EXCEPTION:
+ case EXCEPTION_INVALID_DISPOSITION:
+ case EXCEPTION_GUARD_PAGE:
+ case EXCEPTION_INVALID_HANDLE:
+ *statPtr = SIGSEGV;
+ break;
- case EXCEPTION_DATATYPE_MISALIGNMENT:
- *statPtr = SIGBUS;
- break;
-
- case EXCEPTION_BREAKPOINT:
- case EXCEPTION_SINGLE_STEP:
- *statPtr = SIGTRAP;
- break;
+ case EXCEPTION_DATATYPE_MISALIGNMENT:
+ *statPtr = SIGBUS;
+ break;
- case CONTROL_C_EXIT:
- *statPtr = SIGINT;
- break;
+ case EXCEPTION_BREAKPOINT:
+ case EXCEPTION_SINGLE_STEP:
+ *statPtr = SIGTRAP;
+ break;
- default:
- /*
- * Non-exceptional, normal, exit code. Note that the
- * exit code is truncated to a signed short range
- * [-32768,32768) whether it fits into this range or not.
- *
- * BUG: Even though the exit code is a DWORD, it is
- * understood by convention to be a signed integer, yet
- * there isn't enough room to fit this into the POSIX
- * style waitstatus mask without truncating it.
- */
- *statPtr = (((int)(short) exitCode << 8) & 0xffff00);
- break;
+ case CONTROL_C_EXIT:
+ *statPtr = SIGINT;
+ break;
+
+ default:
+ /*
+ * Non-exceptional, normal, exit code. Note that the exit code is
+ * truncated to a signed short range [-32768,32768) whether it
+ * fits into this range or not.
+ *
+ * BUG: Even though the exit code is a DWORD, it is understood by
+ * convention to be a signed integer, yet there isn't enough room
+ * to fit this into the POSIX style waitstatus mask without
+ * truncating it.
+ */
+
+ *statPtr = (((int)(short) exitCode << 8) & 0xffff00);
+ break;
}
result = pid;
} else {
errno = ECHILD;
- *statPtr = ECHILD;
+ *statPtr = ECHILD;
result = (Tcl_Pid) -1;
}
@@ -2665,23 +2647,23 @@ Tcl_WaitPid(
*
* TclWinAddProcess --
*
- * Add a process to the process list so that we can use
- * Tcl_WaitPid on the process.
+ * Add a process to the process list so that we can use Tcl_WaitPid on
+ * the process.
*
* Results:
- * None
+ * None
*
* Side effects:
- * Adds the specified process handle to the process list so
- * Tcl_WaitPid knows about it.
+ * Adds the specified process handle to the process list so Tcl_WaitPid
+ * knows about it.
*
*----------------------------------------------------------------------
*/
void
TclWinAddProcess(hProcess, id)
- HANDLE hProcess; /* Handle to process */
- DWORD id; /* Global process identifier */
+ HANDLE hProcess; /* Handle to process */
+ DWORD id; /* Global process identifier */
{
ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
@@ -2700,8 +2682,8 @@ TclWinAddProcess(hProcess, id)
*
* Tcl_PidObjCmd --
*
- * This procedure is invoked to process the "pid" Tcl command.
- * See the user documentation for details on what it does.
+ * This function is invoked to process the "pid" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -2735,9 +2717,9 @@ Tcl_PidObjCmd(
wsprintfA(buf, "%lu", (unsigned long) getpid());
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
} else {
- chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL),
+ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL),
NULL);
- if (chan == (Tcl_Channel) NULL) {
+ if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanTypePtr = Tcl_GetChannelType(chan);
@@ -2745,9 +2727,9 @@ Tcl_PidObjCmd(
return TCL_OK;
}
- pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
+ pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
- for (i = 0; i < pipePtr->numPids; i++) {
+ for (i = 0; i < pipePtr->numPids; i++) {
wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
Tcl_NewStringObj(buf, -1));
@@ -2762,20 +2744,19 @@ Tcl_PidObjCmd(
*
* WaitForRead --
*
- * Wait until some data is available, the pipe is at
- * EOF or the reader thread is blocked waiting for data (if the
- * channel is in non-blocking mode).
+ * Wait until some data is available, the pipe is at EOF or the reader
+ * thread is blocked waiting for data (if the channel is in non-blocking
+ * mode).
*
* Results:
- * Returns 1 if pipe is readable. Returns 0 if there is no data
- * on the pipe, but there is buffered data. Returns -1 if an
- * error occurred. If an error occurred, the threads may not
- * be synchronized.
+ * Returns 1 if pipe is readable. Returns 0 if there is no data on the
+ * pipe, but there is buffered data. Returns -1 if an error occurred. If
+ * an error occurred, the threads may not be synchronized.
*
* Side effects:
- * Updates the shared state flags and may consume 1 byte of data
- * from the pipe. If no error occurred, the reader thread is
- * blocked waiting for a signal from the main thread.
+ * Updates the shared state flags and may consume 1 byte of data from the
+ * pipe. If no error occurred, the reader thread is blocked waiting for a
+ * signal from the main thread.
*
*----------------------------------------------------------------------
*/
@@ -2783,8 +2764,8 @@ Tcl_PidObjCmd(
static int
WaitForRead(
PipeInfo *infoPtr, /* Pipe state. */
- int blocking) /* Indicates whether call should be
- * blocking or not. */
+ int blocking) /* Indicates whether call should be blocking
+ * or not. */
{
DWORD timeout, count;
HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;
@@ -2793,7 +2774,7 @@ WaitForRead(
/*
* Synchronize with the reader thread.
*/
-
+
timeout = blocking ? INFINITE : 0;
if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) {
/*
@@ -2806,11 +2787,10 @@ WaitForRead(
}
/*
- * At this point, the two threads are synchronized, so it is safe
- * to access shared state.
+ * At this point, the two threads are synchronized, so it is safe to
+ * access shared state.
*/
-
/*
* If the pipe has hit EOF, it is always readable.
*/
@@ -2818,7 +2798,7 @@ WaitForRead(
if (infoPtr->readFlags & PIPE_EOF) {
return 1;
}
-
+
/*
* Check to see if there is any data sitting in the pipe.
*/
@@ -2826,6 +2806,7 @@ WaitForRead(
if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0,
(LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) {
TclWinConvertError(GetLastError());
+
/*
* Check to see if the peek failed because of EOF.
*/
@@ -2855,8 +2836,8 @@ WaitForRead(
}
/*
- * The pipe isn't readable, but there is some data sitting
- * in the buffer, so return immediately.
+ * The pipe isn't readable, but there is some data sitting in the
+ * buffer, so return immediately.
*/
if (infoPtr->readFlags & PIPE_EXTRABYTE) {
@@ -2864,10 +2845,9 @@ WaitForRead(
}
/*
- * There wasn't any data available, so reset the thread and
- * try again.
+ * There wasn't any data available, so reset the thread and try again.
*/
-
+
ResetEvent(infoPtr->readable);
SetEvent(infoPtr->startReader);
}
@@ -2878,18 +2858,17 @@ WaitForRead(
*
* PipeReaderThread --
*
- * This function runs in a separate thread and waits for input
- * to become available on a pipe.
+ * This function runs in a separate thread and waits for input to become
+ * available on a pipe.
*
* Results:
* None.
*
* Side effects:
- * Signals the main thread when input become available. May
- * cause the main thread to wake up by posting a message. May
- * consume one byte from the pipe for each wait operation. Will
- * cause a memory leak of ~4k, if forcefully terminated with
- * TerminateThread().
+ * Signals the main thread when input become available. May cause the
+ * main thread to wake up by posting a message. May consume one byte from
+ * the pipe for each wait operation. Will cause a memory leak of ~4k, if
+ * forcefully terminated with TerminateThread().
*
*----------------------------------------------------------------------
*/
@@ -2909,33 +2888,33 @@ PipeReaderThread(LPVOID arg)
while (!done) {
/*
- * Wait for the main thread to signal before attempting to wait
- * on the pipe becoming readable.
+ * Wait for the main thread to signal before attempting to wait on the
+ * pipe becoming readable.
*/
waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);
if (waitResult != (WAIT_OBJECT_0 + 1)) {
/*
- * The start event was not signaled. It might be the stop event
- * or an error, so exit.
+ * The start event was not signaled. It might be the stop event or
+ * an error, so exit.
*/
break;
}
/*
- * Try waiting for 0 bytes. This will block until some data is
- * available on NT, but will return immediately on Win 95. So,
- * if no data is available after the first read, we block until
- * we can read a single byte off of the pipe.
+ * Try waiting for 0 bytes. This will block until some data is
+ * available on NT, but will return immediately on Win 95. So, if no
+ * data is available after the first read, we block until we can read
+ * a single byte off of the pipe.
*/
if (ReadFile(handle, NULL, 0, &count, NULL) == FALSE ||
PeekNamedPipe(handle, NULL, 0, NULL, &count, NULL) == FALSE) {
/*
- * The error is a result of an EOF condition, so set the
- * EOF bit before signalling the main thread.
+ * The error is a result of an EOF condition, so set the EOF bit
+ * before signalling the main thread.
*/
err = GetLastError();
@@ -2949,8 +2928,8 @@ PipeReaderThread(LPVOID arg)
if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL)
!= FALSE) {
/*
- * One byte was consumed as a side effect of waiting
- * for the pipe to become readable.
+ * One byte was consumed as a side effect of waiting for the
+ * pipe to become readable.
*/
infoPtr->readFlags |= PIPE_EXTRABYTE;
@@ -2970,23 +2949,27 @@ PipeReaderThread(LPVOID arg)
}
}
-
+
/*
- * Signal the main thread by signalling the readable event and
- * then waking up the notifier thread.
+ * Signal the main thread by signalling the readable event and then
+ * waking up the notifier thread.
*/
SetEvent(infoPtr->readable);
-
+
/*
- * Alert the foreground thread. Note that we need to treat this like
- * a critical section so the foreground thread does not terminate
- * this thread while we are holding a mutex in the notifier code.
+ * Alert the foreground thread. Note that we need to treat this like a
+ * critical section so the foreground thread does not terminate this
+ * thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&pipeMutex);
if (infoPtr->threadId != NULL) {
- /* TIP #218. When in flight ignore the event, no one will receive it anyway */
+ /*
+ * TIP #218. When in flight ignore the event, no one will receive
+ * it anyway.
+ */
+
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&pipeMutex);
@@ -3000,15 +2983,14 @@ PipeReaderThread(LPVOID arg)
*
* PipeWriterThread --
*
- * This function runs in a separate thread and writes data
- * onto a pipe.
+ * This function runs in a separate thread and writes data onto a pipe.
*
* Results:
* Always returns 0.
*
* Side effects:
- * Signals the main thread when an output operation is completed.
- * May cause the main thread to wake up by posting a message.
+ * Signals the main thread when an output operation is completed. May
+ * cause the main thread to wake up by posting a message.
*
*----------------------------------------------------------------------
*/
@@ -3016,7 +2998,6 @@ PipeReaderThread(LPVOID arg)
static DWORD WINAPI
PipeWriterThread(LPVOID arg)
{
-
PipeInfo *infoPtr = (PipeInfo *)arg;
HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle;
DWORD count, toWrite;
@@ -3037,8 +3018,8 @@ PipeWriterThread(LPVOID arg)
if (waitResult != (WAIT_OBJECT_0 + 1)) {
/*
- * The start event was not signaled. It might be the stop event
- * or an error, so exit.
+ * The start event was not signaled. It might be the stop event or
+ * an error, so exit.
*/
break;
@@ -3054,30 +3035,34 @@ PipeWriterThread(LPVOID arg)
while (toWrite > 0) {
if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) {
infoPtr->writeError = GetLastError();
- done = 1;
+ done = 1;
break;
} else {
toWrite -= count;
buf += count;
}
}
-
+
/*
- * Signal the main thread by signalling the writable event and
- * then waking up the notifier thread.
+ * Signal the main thread by signalling the writable event and then
+ * waking up the notifier thread.
*/
SetEvent(infoPtr->writable);
/*
- * Alert the foreground thread. Note that we need to treat this like
- * a critical section so the foreground thread does not terminate
- * this thread while we are holding a mutex in the notifier code.
+ * Alert the foreground thread. Note that we need to treat this like a
+ * critical section so the foreground thread does not terminate this
+ * thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&pipeMutex);
if (infoPtr->threadId != NULL) {
- /* TIP #218. When in flight ignore the event, no one will receive it anyway */
+ /*
+ * TIP #218. When in flight ignore the event, no one will receive
+ * it anyway.
+ */
+
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&pipeMutex);
@@ -3103,33 +3088,43 @@ PipeWriterThread(LPVOID arg)
*/
static void
-PipeThreadActionProc (instanceData, action)
- ClientData instanceData;
- int action;
+PipeThreadActionProc(instanceData, action)
+ ClientData instanceData;
+ int action;
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
- /* We do not access firstPipePtr in the thread structures. This is
- * not for all pipes managed by the thread, but only those we are
- * watching. Removal of the filevent handlers before transfer thus
- * takes care of this structure.
+ /*
+ * We do not access firstPipePtr in the thread structures. This is not for
+ * all pipes managed by the thread, but only those we are watching.
+ * Removal of the filevent handlers before transfer thus takes care of
+ * this structure.
*/
Tcl_MutexLock(&pipeMutex);
if (action == TCL_CHANNEL_THREAD_INSERT) {
- /* We can't copy the thread information from the channel when
- * the channel is created. At this time the channel back
- * pointer has not been set yet. However in that case the
- * threadId has already been set by TclpCreateCommandChannel
- * itself, so the structure is still good.
+ /*
+ * We can't copy the thread information from the channel when the
+ * channel is created. At this time the channel back pointer has not
+ * been set yet. However in that case the threadId has already been
+ * set by TclpCreateCommandChannel itself, so the structure is still
+ * good.
*/
- PipeInit ();
- if (infoPtr->channel != NULL) {
- infoPtr->threadId = Tcl_GetChannelThread (infoPtr->channel);
+ PipeInit();
+ if (infoPtr->channel != NULL) {
+ infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&pipeMutex);
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 5347cbe..902237d 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -1,17 +1,17 @@
/*
* tclWinReg.c --
*
- * This file contains the implementation of the "registry" Tcl
- * built-in command. This command is built as a dynamically
- * loadable extension in a separate DLL.
+ * This file contains the implementation of the "registry" Tcl built-in
+ * command. This command is built as a dynamically loadable extension in
+ * a separate DLL.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
* Copyright (c) 1998-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: tclWinReg.c,v 1.32 2004/10/07 00:55:36 dgp Exp $
+ * RCS: @(#) $Id: tclWinReg.c,v 1.33 2005/07/24 22:56:49 dkf Exp $
*/
#include "tclInt.h"
@@ -37,15 +37,15 @@
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
/*
- * The following flag is used in OpenKeys to indicate that the specified
- * key should be created if it doesn't currently exist.
+ * The following flag is used in OpenKeys to indicate that the specified key
+ * should be created if it doesn't currently exist.
*/
#define REG_CREATE 1
/*
- * The following tables contain the mapping from registry root names
- * to the system predefined keys.
+ * The following tables contain the mapping from registry root names to the
+ * system predefined keys.
*/
static CONST char *rootKeyNames[] = {
@@ -62,10 +62,9 @@ static HKEY rootKeys[] = {
static CONST char REGISTRY_ASSOC_KEY[] = "registry::command";
/*
- * The following table maps from registry types to strings. Note that
- * the indices for this array are the same as the constants for the
- * known registry types so we don't need a separate table to hold the
- * mapping.
+ * The following table maps from registry types to strings. Note that the
+ * indices for this array are the same as the constants for the known registry
+ * types so we don't need a separate table to hold the mapping.
*/
static CONST char *typeNames[] = {
@@ -77,9 +76,9 @@ static DWORD lastType = REG_RESOURCE_LIST;
/*
* The following structures allow us to select between the Unicode and ASCII
- * interfaces at run time based on whether Unicode APIs are available. The
- * Unicode APIs are preferable because they will handle characters outside
- * of the current code page.
+ * interfaces at run time based on whether Unicode APIs are available. The
+ * Unicode APIs are preferable because they will handle characters outside of
+ * the current code page.
*/
typedef struct RegWinProcs {
@@ -87,7 +86,7 @@ typedef struct RegWinProcs {
LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY);
LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
- DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
+ DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
@@ -114,7 +113,7 @@ static RegWinProcs asciiProcs = {
(LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
- DWORD *)) RegCreateKeyExA,
+ DWORD *)) RegCreateKeyExA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
(LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
@@ -139,7 +138,7 @@ static RegWinProcs unicodeProcs = {
(LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
- DWORD *)) RegCreateKeyExW,
+ DWORD *)) RegCreateKeyExW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
(LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
@@ -204,7 +203,7 @@ EXTERN int Registry_Unload(Tcl_Interp *interp, int flags);
*
* Registry_Init --
*
- * This procedure initializes the registry command.
+ * This function initializes the registry command.
*
* Results:
* A standard Tcl result.
@@ -247,7 +246,7 @@ Registry_Init(
*
* Registry_Unload --
*
- * This procedure removes the registry command.
+ * This function removes the registry command.
*
* Results:
* A standard Tcl result.
@@ -266,7 +265,7 @@ Registry_Unload(
Tcl_Command cmd;
Tcl_Obj *objv[3];
- /*
+ /*
* Unregister the registry package. There is no Tcl_PkgForget()
*/
@@ -292,8 +291,8 @@ Registry_Unload(
*
* DeleteCmd --
*
- * Cleanup the interp command token so that unloading doesn't try
- * to re-delete the command (which will crash).
+ * Cleanup the interp command token so that unloading doesn't try to
+ * re-delete the command (which will crash).
*
* Results:
* None.
@@ -356,65 +355,64 @@ RegistryObjCmd(
}
switch (index) {
- case BroadcastIdx: /* broadcast */
- return BroadcastValue(interp, objc, objv);
- break;
- case DeleteIdx: /* delete */
- if (objc == 3) {
- return DeleteKey(interp, objv[2]);
- } else if (objc == 4) {
- return DeleteValue(interp, objv[2], objv[3]);
- }
- errString = "keyName ?valueName?";
- break;
- case GetIdx: /* get */
- if (objc == 4) {
- return GetValue(interp, objv[2], objv[3]);
- }
- errString = "keyName valueName";
- break;
- case KeysIdx: /* keys */
- if (objc == 3) {
- return GetKeyNames(interp, objv[2], NULL);
- } else if (objc == 4) {
- return GetKeyNames(interp, objv[2], objv[3]);
- }
- errString = "keyName ?pattern?";
- break;
- case SetIdx: /* set */
- if (objc == 3) {
- HKEY key;
+ case BroadcastIdx: /* broadcast */
+ return BroadcastValue(interp, objc, objv);
+ break;
+ case DeleteIdx: /* delete */
+ if (objc == 3) {
+ return DeleteKey(interp, objv[2]);
+ } else if (objc == 4) {
+ return DeleteValue(interp, objv[2], objv[3]);
+ }
+ errString = "keyName ?valueName?";
+ break;
+ case GetIdx: /* get */
+ if (objc == 4) {
+ return GetValue(interp, objv[2], objv[3]);
+ }
+ errString = "keyName valueName";
+ break;
+ case KeysIdx: /* keys */
+ if (objc == 3) {
+ return GetKeyNames(interp, objv[2], NULL);
+ } else if (objc == 4) {
+ return GetKeyNames(interp, objv[2], objv[3]);
+ }
+ errString = "keyName ?pattern?";
+ break;
+ case SetIdx: /* set */
+ if (objc == 3) {
+ HKEY key;
- /*
- * Create the key and then close it immediately.
- */
+ /*
+ * Create the key and then close it immediately.
+ */
- if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key)
- != TCL_OK) {
- return TCL_ERROR;
- }
- RegCloseKey(key);
- return TCL_OK;
- } else if (objc == 5 || objc == 6) {
- Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
- return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
+ if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
+ return TCL_ERROR;
}
- errString = "keyName ?valueName data ?type??";
- break;
- case TypeIdx: /* type */
- if (objc == 4) {
- return GetType(interp, objv[2], objv[3]);
- }
- errString = "keyName valueName";
- break;
- case ValuesIdx: /* values */
- if (objc == 3) {
- return GetValueNames(interp, objv[2], NULL);
- } else if (objc == 4) {
- return GetValueNames(interp, objv[2], objv[3]);
- }
- errString = "keyName ?pattern?";
- break;
+ RegCloseKey(key);
+ return TCL_OK;
+ } else if (objc == 5 || objc == 6) {
+ Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
+ return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
+ }
+ errString = "keyName ?valueName data ?type??";
+ break;
+ case TypeIdx: /* type */
+ if (objc == 4) {
+ return GetType(interp, objv[2], objv[3]);
+ }
+ errString = "keyName valueName";
+ break;
+ case ValuesIdx: /* values */
+ if (objc == 3) {
+ return GetValueNames(interp, objv[2], NULL);
+ } else if (objc == 4) {
+ return GetValueNames(interp, objv[2], objv[3]);
+ }
+ errString = "keyName ?pattern?";
+ break;
}
Tcl_WrongNumArgs(interp, 2, objv, errString);
return TCL_ERROR;
@@ -456,8 +454,8 @@ DeleteKey(
buffer = ckalloc((unsigned int) length + 1);
strcpy(buffer, keyName);
- if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)
- != TCL_OK) {
+ if (ParseKeyName(interp, buffer, &hostName, &rootKey,
+ &keyName) != TCL_OK) {
ckfree(buffer);
return TCL_ERROR;
}
@@ -483,12 +481,11 @@ DeleteKey(
ckfree(buffer);
if (result == ERROR_FILE_NOT_FOUND) {
return TCL_OK;
- } else {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unable to delete key: ", -1));
- AppendSystemError(interp, result);
- return TCL_ERROR;
}
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unable to delete key: ", -1));
+ AppendSystemError(interp, result);
+ return TCL_ERROR;
}
/*
@@ -572,13 +569,13 @@ DeleteValue(
*
* GetKeyNames --
*
- * This function enumerates the subkeys of a given key. If the
- * optional pattern is supplied, then only keys that match the
- * pattern will be returned.
+ * This function enumerates the subkeys of a given key. If the optional
+ * pattern is supplied, then only keys that match the pattern will be
+ * returned.
*
* Results:
- * Returns the list of subkeys in the result object of the
- * interpreter, or an error message on failure.
+ * Returns the list of subkeys in the result object of the interpreter,
+ * or an error message on failure.
*
* Side effects:
* None.
@@ -603,8 +600,8 @@ GetKeyNames(
* Attempt to open the key for enumeration.
*/
- if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)
- != TCL_OK) {
+ if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0,
+ &key) != TCL_OK) {
return TCL_ERROR;
}
@@ -615,8 +612,8 @@ GetKeyNames(
}
/*
- * Enumerate over the subkeys until we get an error, indicating the
- * end of the list.
+ * Enumerate over the subkeys until we get an error, indicating the end of
+ * the list.
*/
resultPtr = Tcl_NewObj();
@@ -646,8 +643,8 @@ GetKeyNames(
*
* GetType --
*
- * This function gets the type of a given registry value and
- * places it in the interpreter result.
+ * This function gets the type of a given registry value and places it in
+ * the interpreter result.
*
* Results:
* Returns a normal Tcl result.
@@ -701,8 +698,8 @@ GetType(
}
/*
- * Set the type into the result. Watch out for unknown types.
- * If we don't know about the type, just use the numeric value.
+ * Set the type into the result. Watch out for unknown types. If we don't
+ * know about the type, just use the numeric value.
*/
if (type > lastType || type < 0) {
@@ -718,9 +715,8 @@ GetType(
*
* GetValue --
*
- * This function gets the contents of a registry value and places
- * a list containing the data and the type in the interpreter
- * result.
+ * This function gets the contents of a registry value and places a list
+ * containing the data and the type in the interpreter result.
*
* Results:
* Returns a normal Tcl result.
@@ -748,16 +744,15 @@ GetValue(
* Attempt to open the key for reading.
*/
- if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
- != TCL_OK) {
+ if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
/*
- * Initialize a Dstring to maximum statically allocated size
- * we could get one more byte by avoiding Tcl_DStringSetLength()
- * and just setting length to TCL_DSTRING_STATIC_SIZE, but this
- * should be safer if the implementation of Dstrings changes.
+ * Initialize a Dstring to maximum statically allocated size we could get
+ * one more byte by avoiding Tcl_DStringSetLength() and just setting
+ * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the
+ * implementation of Dstrings changes.
*
* This allows short values to be read from the registy in one call.
* Longer values need a second call with an expanded DString.
@@ -774,13 +769,14 @@ GetValue(
(BYTE *) Tcl_DStringValue(&data), &length);
while (result == ERROR_MORE_DATA) {
/*
- * The Windows docs say that in this error case, we just need
- * to expand our buffer and request more data.
- * Required for HKEY_PERFORMANCE_DATA
+ * The Windows docs say that in this error case, we just need to
+ * expand our buffer and request more data. Required for
+ * HKEY_PERFORMANCE_DATA
*/
+
length *= 2;
- Tcl_DStringSetLength(&data, (int) length);
- result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue,
+ Tcl_DStringSetLength(&data, (int) length);
+ result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
Tcl_DStringFree(&buf);
@@ -795,15 +791,15 @@ GetValue(
}
/*
- * If the data is a 32-bit quantity, store it as an integer object. If it
- * is a multi-string, store it as a list of strings. For null-terminated
- * strings, append up the to first null. Otherwise, store it as a binary
+ * If the data is a 32-bit quantity, store it as an integer object. If it
+ * is a multi-string, store it as a list of strings. For null-terminated
+ * strings, append up the to first null. Otherwise, store it as a binary
* string.
*/
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
- (int) ConvertDWORD(type, *((DWORD*) Tcl_DStringValue(&data)))));
+ Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type,
+ *((DWORD*) Tcl_DStringValue(&data)))));
} else if (type == REG_MULTI_SZ) {
char *p = Tcl_DStringValue(&data);
char *end = Tcl_DStringValue(&data) + length;
@@ -811,11 +807,11 @@ GetValue(
/*
* Multistrings are stored as an array of null-terminated strings,
- * terminated by two null characters. Also do a bounds check in
- * case we get bogus data.
+ * terminated by two null characters. Also do a bounds check in case
+ * we get bogus data.
*/
-
- while (p < end && ((regWinProcs->useWide)
+
+ while (p < end && ((regWinProcs->useWide)
? *((Tcl_UniChar *)p) : *p) != 0) {
Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
@@ -849,9 +845,9 @@ GetValue(
*
* GetValueNames --
*
- * This function enumerates the values of the a given key. If
- * the optional pattern is supplied, then only value names that
- * match the pattern will be returned.
+ * This function enumerates the values of the a given key. If the
+ * optional pattern is supplied, then only value names that match the
+ * pattern will be returned.
*
* Results:
* Returns the list of value names in the result object of the
@@ -916,8 +912,8 @@ GetValueNames(
/*
* Enumerate the values under the given subkey until we get an error,
- * indicating the end of the list. Note that we need to reset size
- * after each iteration because RegEnumValue smashes the old value.
+ * indicating the end of the list. Note that we need to reset size after
+ * each iteration because RegEnumValue smashes the old value.
*/
size = maxSize;
@@ -929,7 +925,8 @@ GetValueNames(
size *= 2;
}
- Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds);
+ Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size,
+ &ds);
name = Tcl_DStringValue(&ds);
if (!pattern || Tcl_StringMatch(name, pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
@@ -947,7 +944,7 @@ GetValueNames(
Tcl_SetObjResult(interp, resultPtr);
Tcl_DStringFree(&buffer);
- done:
+ done:
RegCloseKey(key);
return result;
}
@@ -957,12 +954,11 @@ GetValueNames(
*
* OpenKey --
*
- * This function opens the specified key. This function is a
- * simple wrapper around ParseKeyName and OpenSubKey.
+ * This function opens the specified key. This function is a simple
+ * wrapper around ParseKeyName and OpenSubKey.
*
* Results:
- * Returns the opened key in the keyPtr argument and a Tcl
- * result code.
+ * Returns the opened key in the keyPtr argument and a Tcl result code.
*
* Side effects:
* None.
@@ -1009,12 +1005,12 @@ OpenKey(
*
* OpenSubKey --
*
- * This function opens a given subkey of a root key on the
- * specified host.
+ * This function opens a given subkey of a root key on the specified
+ * host.
*
* Results:
- * Returns the opened key in the keyPtr and a Windows error code
- * as the return value.
+ * Returns the opened key in the keyPtr and a Windows error code as the
+ * return value.
*
* Side effects:
* None.
@@ -1049,8 +1045,8 @@ OpenSubKey(
}
/*
- * Now open the specified key with the requested permissions. Note
- * that this key must be closed by the caller.
+ * Now open the specified key with the requested permissions. Note that
+ * this key must be closed by the caller.
*/
keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
@@ -1058,19 +1054,16 @@ OpenSubKey(
DWORD create;
result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL,
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
+ } else if (rootKey == HKEY_PERFORMANCE_DATA) {
+ /*
+ * Here we fudge it for this special root key. See MSDN for more info
+ * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
+ */
+ *keyPtr = HKEY_PERFORMANCE_DATA;
+ result = ERROR_SUCCESS;
} else {
- if (rootKey == HKEY_PERFORMANCE_DATA) {
- /*
- * Here we fudge it for this special root key.
- * See MSDN for more info on HKEY_PERFORMANCE_DATA and
- * the peculiarities surrounding it
- */
- *keyPtr = HKEY_PERFORMANCE_DATA;
- result = ERROR_SUCCESS;
- } else {
- result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0,
- mode, keyPtr);
- }
+ result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode,
+ keyPtr);
}
Tcl_DStringFree(&buf);
@@ -1089,15 +1082,12 @@ OpenSubKey(
*
* ParseKeyName --
*
- * This function parses a key name into the host, root, and subkey
- * parts.
+ * This function parses a key name into the host, root, and subkey parts.
*
* Results:
- * The pointers to the start of the host and subkey names are
- * returned in the hostNamePtr and keyNamePtr variables. The
- * specified root HKEY is returned in rootKeyPtr. Returns
- * a standard Tcl result.
- *
+ * The pointers to the start of the host and subkey names are returned in
+ * the hostNamePtr and keyNamePtr variables. The specified root HKEY is
+ * returned in rootKeyPtr. Returns a standard Tcl result.
*
* Side effects:
* Modifies the name string by inserting nulls.
@@ -1173,9 +1163,9 @@ ParseKeyName(
*
* RecursiveDeleteKey --
*
- * This function recursively deletes all the keys below a starting
- * key. Although Windows 95 does this automatically, we still need
- * to do this for Windows NT.
+ * This function recursively deletes all the keys below a starting key.
+ * Although Windows 95 does this automatically, we still need to do this
+ * for Windows NT.
*
* Results:
* Returns a Windows error code.
@@ -1245,9 +1235,9 @@ RecursiveDeleteKey(
*
* SetValue --
*
- * This function sets the contents of a registry value. If
- * the key or value does not exist, it will be created. If it
- * does exist, then the data and type will be replaced.
+ * This function sets the contents of a registry value. If the key or
+ * value does not exist, it will be created. If it does exist, then the
+ * data and type will be replaced.
*
* Results:
* Returns a normal Tcl result.
@@ -1311,9 +1301,9 @@ SetValue(
}
/*
- * Append the elements as null terminated strings. Note that
- * we must not assume the length of the string in case there are
- * embedded nulls, which aren't allowed in REG_MULTI_SZ values.
+ * Append the elements as null terminated strings. Note that we must
+ * not assume the length of the string in case there are embedded
+ * nulls, which aren't allowed in REG_MULTI_SZ values.
*/
Tcl_DStringInit(&data);
@@ -1321,8 +1311,8 @@ SetValue(
Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);
/*
- * Add a null character to separate this value from the next.
- * We accomplish this by growing the string by one byte. Since the
+ * Add a null character to separate this value from the next. We
+ * accomplish this by growing the string by one byte. Since the
* DString always tacks on an extra null byte, the new byte will
* already be set to null.
*/
@@ -1366,10 +1356,13 @@ SetValue(
result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
(BYTE *)data, (DWORD) length);
}
+
Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
+
if (result != ERROR_SUCCESS) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to set value: ", -1));
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("unable to set value: ", -1));
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -1381,9 +1374,8 @@ SetValue(
*
* BroadcastValue --
*
- * This function broadcasts a WM_SETTINGCHANGE message to indicate
- * to other programs that we have changed the contents of a registry
- * value.
+ * This function broadcasts a WM_SETTINGCHANGE message to indicate to
+ * other programs that we have changed the contents of a registry value.
*
* Results:
* Returns a normal Tcl result.
@@ -1413,7 +1405,8 @@ BroadcastValue(
if (objc > 3) {
str = Tcl_GetStringFromObj(objv[3], &len);
- if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", (size_t) len)) {
+ if ((len < 2) || (*str != '-')
+ || strncmp(str, "-timeout", (size_t) len)) {
Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
return TCL_ERROR;
}
@@ -1430,6 +1423,7 @@ BroadcastValue(
/*
* Use the ignore the result.
*/
+
result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
(WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);
@@ -1446,8 +1440,8 @@ BroadcastValue(
*
* AppendSystemError --
*
- * This routine formats a Windows system error message and places
- * it into the interpreter result.
+ * This routine formats a Windows system error message and places it into
+ * the interpreter result.
*
* Results:
* None.
@@ -1512,6 +1506,7 @@ AppendSystemError(
/*
* Trim the trailing CR/LF from the system message.
*/
+
if (msg[length-1] == '\n') {
msg[--length] = 0;
}
@@ -1535,8 +1530,8 @@ AppendSystemError(
*
* ConvertDWORD --
*
- * This function determines whether a DWORD needs to be byte
- * swapped, and returns the appropriately swapped value.
+ * This function determines whether a DWORD needs to be byte swapped, and
+ * returns the appropriately swapped value.
*
* Results:
* Returns a converted DWORD.
@@ -1562,3 +1557,11 @@ ConvertDWORD(
localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
return (type != localType) ? SWAPLONG(value) : value;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 582f952..ba71aad 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -1,17 +1,17 @@
/*
* tclWinSerial.c --
*
- * This file implements the Windows-specific serial port functions,
- * and the "serial" channel driver.
+ * This file implements the Windows-specific serial port functions, and
+ * the "serial" channel driver.
*
* Copyright (c) 1999 by Scriptics Corp.
*
- * 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.
*
* Serial functionality implemented by Rolf.Schroedter@dlr.de
*
- * RCS: @(#) $Id: tclWinSerial.c,v 1.30 2005/05/10 18:35:40 kennykb Exp $
+ * RCS: @(#) $Id: tclWinSerial.c,v 1.31 2005/07/24 22:56:49 dkf Exp $
*/
#include "tclWinInt.h"
@@ -39,29 +39,30 @@ TCL_DECLARE_MUTEX(serialMutex)
* Bit masks used in the flags field of the SerialInfo structure below.
*/
-#define SERIAL_PENDING (1<<0) /* Message is pending in the queue. */
-#define SERIAL_ASYNC (1<<1) /* Channel is non-blocking. */
+#define SERIAL_PENDING (1<<0) /* Message is pending in the queue. */
+#define SERIAL_ASYNC (1<<1) /* Channel is non-blocking. */
/*
* Bit masks used in the sharedFlags field of the SerialInfo structure below.
*/
-#define SERIAL_EOF (1<<2) /* Serial has reached EOF. */
-#define SERIAL_ERROR (1<<4)
+#define SERIAL_EOF (1<<2) /* Serial has reached EOF. */
+#define SERIAL_ERROR (1<<4)
/*
* Default time to block between checking status on the serial port.
*/
-#define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */
+#define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */
/*
* Define Win32 read/write error masks returned by ClearCommError()
*/
-#define SERIAL_READ_ERRORS ( CE_RXOVER | CE_OVERRUN | CE_RXPARITY \
- | CE_FRAME | CE_BREAK )
-#define SERIAL_WRITE_ERRORS ( CE_TXFULL | CE_PTO )
+#define SERIAL_READ_ERRORS \
+ (CE_RXOVER | CE_OVERRUN | CE_RXPARITY | CE_FRAME | CE_BREAK)
+#define SERIAL_WRITE_ERRORS \
+ (CE_TXFULL | CE_PTO)
/*
* This structure describes per-instance data for a serial based channel.
@@ -78,60 +79,57 @@ typedef struct SerialInfo {
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which events should be reported. */
int flags; /* State flags, see above for a list. */
- int readable; /* flag that the channel is readable */
- int writable; /* flag that the channel is writable */
- int blockTime; /* max. blocktime in msec */
+ int readable; /* Flag that the channel is readable. */
+ int writable; /* Flag that the channel is writable. */
+ int blockTime; /* Maximum blocktime in msec. */
unsigned int lastEventTime; /* Time in milliseconds since last readable
- * event */
+ * event. */
/* Next readable event only after blockTime */
DWORD error; /* pending error code returned by
* ClearCommError() */
DWORD lastError; /* last error code, can be fetched with
* fconfigure chan -lasterror */
- DWORD sysBufRead; /* Win32 system buffer size for read ops,
+ DWORD sysBufRead; /* Win32 system buffer size for read ops,
* default=4096 */
- DWORD sysBufWrite; /* Win32 system buffer size for write ops,
+ DWORD sysBufWrite; /* Win32 system buffer size for write ops,
* default=4096 */
Tcl_ThreadId threadId; /* Thread to which events should be reported.
* This value is used by the reader/writer
* threads. */
- OVERLAPPED osRead; /* OVERLAPPED structure for read operations */
+ OVERLAPPED osRead; /* OVERLAPPED structure for read operations. */
OVERLAPPED osWrite; /* OVERLAPPED structure for write operations */
HANDLE writeThread; /* Handle to writer thread. */
- CRITICAL_SECTION csWrite; /* Writer thread synchronisation */
+ CRITICAL_SECTION csWrite; /* Writer thread synchronisation. */
HANDLE evWritable; /* Manual-reset event to signal when the
- * writer thread has finished waiting for
- * the current buffer to be written. */
+ * writer thread has finished waiting for the
+ * current buffer to be written. */
HANDLE evStartWriter; /* Auto-reset event used by the main thread to
- * signal when the writer thread should attempt
- * to write to the serial. */
+ * signal when the writer thread should
+ * attempt to write to the serial. */
HANDLE evStopWriter; /* Auto-reset event used by the main thread to
* signal when the writer thread should close.
*/
DWORD writeError; /* An error caused by the last background
- * write. Set to 0 if no error has been
- * detected. This word is shared with the
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
* writer thread so access must be
- * synchronized with the evWritable object.
- */
- char *writeBuf; /* Current background output buffer.
- * Access is synchronized with the evWritable
- * object. */
- int writeBufLen; /* Size of write buffer. Access is
- * synchronized with the evWritable
- * object. */
- int toWrite; /* Current amount to be written. Access is
+ * synchronized with the evWritable object. */
+ char *writeBuf; /* Current background output buffer. Access is
+ * synchronized with the evWritable object. */
+ int writeBufLen; /* Size of write buffer. Access is
+ * synchronized with the evWritable object. */
+ int toWrite; /* Current amount to be written. Access is
* synchronized with the evWritable object. */
int writeQueue; /* Number of bytes pending in output queue.
- * Offset to DCB.cbInQue.
- * Used to query [fconfigure -queue] */
+ * Offset to DCB.cbInQue. Used to query
+ * [fconfigure -queue] */
} SerialInfo;
typedef struct ThreadSpecificData {
/*
- * The following pointer refers to the head of the list of serials
- * that are being watched for file events.
+ * The following pointer refers to the head of the list of serials that
+ * are being watched for file events.
*/
SerialInfo *firstSerialPtr;
@@ -140,16 +138,16 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
/*
- * The following structure is what is added to the Tcl event queue when
- * serial events are generated.
+ * The following structure is what is added to the Tcl event queue when serial
+ * events are generated.
*/
typedef struct SerialEvent {
- Tcl_Event header; /* Information that is standard for
- * all events. */
- SerialInfo *infoPtr; /* Pointer to serial info structure. Note
- * that we still have to verify that the
- * serial exists before dereferencing this
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ SerialInfo *infoPtr; /* Pointer to serial info structure. Note that
+ * we still have to verify that the serial
+ * exists before dereferencing this
* pointer. */
} SerialEvent;
@@ -190,18 +188,16 @@ static void SerialSetupProc(ClientData clientData,
static void SerialWatchProc(ClientData instanceData,
int mask);
static void ProcExitHandler(ClientData clientData);
-static int SerialGetOptionProc _ANSI_ARGS_((
- ClientData instanceData,
+static int SerialGetOptionProc(ClientData instanceData,
Tcl_Interp *interp, CONST char *optionName,
- Tcl_DString *dsPtr));
-static int SerialSetOptionProc _ANSI_ARGS_((
- ClientData instanceData,
+ Tcl_DString *dsPtr);
+static int SerialSetOptionProc(ClientData instanceData,
Tcl_Interp *interp, CONST char *optionName,
- CONST char *value));
+ CONST char *value);
static DWORD WINAPI SerialWriterThread(LPVOID arg);
-static void SerialThreadActionProc _ANSI_ARGS_ ((
- ClientData instanceData, int action));
+static void SerialThreadActionProc(ClientData instanceData,
+ int action);
/*
* This structure describes the channel type structure for command serial
@@ -223,8 +219,8 @@ static Tcl_ChannelType serialChannelType = {
SerialBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
- NULL, /* wide seek proc */
- SerialThreadActionProc, /* thread action proc */
+ NULL, /* wide seek proc */
+ SerialThreadActionProc, /* thread action proc */
};
/*
@@ -277,8 +273,8 @@ SerialInit()
*
* SerialExitHandler --
*
- * This function is called to cleanup the serial module before
- * Tcl is unloaded.
+ * This function is called to cleanup the serial module before Tcl is
+ * unloaded.
*
* Results:
* None.
@@ -291,16 +287,15 @@ SerialInit()
static void
SerialExitHandler(
- ClientData clientData) /* Old window proc */
+ ClientData clientData) /* Old window proc */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
SerialInfo *infoPtr;
/*
- * Clear all eventually pending output.
- * Otherwise Tcl's exit could totally block,
- * because it performs a blocking flush on all open channels.
- * Note that serial write operations may be blocked due to handshake.
+ * Clear all eventually pending output. Otherwise Tcl's exit could totally
+ * block, because it performs a blocking flush on all open channels. Note
+ * that serial write operations may be blocked due to handshake.
*/
for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
@@ -316,8 +311,8 @@ SerialExitHandler(
*
* ProcExitHandler --
*
- * This function is called to cleanup the process list before
- * Tcl is unloaded.
+ * This function is called to cleanup the process list before Tcl is
+ * unloaded.
*
* Results:
* None.
@@ -330,7 +325,7 @@ SerialExitHandler(
static void
ProcExitHandler(
- ClientData clientData) /* Old window proc */
+ ClientData clientData) /* Old window proc */
{
Tcl_MutexLock(&serialMutex);
initialized = 0;
@@ -349,12 +344,13 @@ ProcExitHandler(
*
* Side effects:
* Updates the maximum blocking time.
+ *
*----------------------------------------------------------------------
*/
static void
SerialBlockTime(
- int msec) /* milli-seconds */
+ int msec) /* milli-seconds */
{
Tcl_Time blockTime;
@@ -375,6 +371,7 @@ SerialBlockTime(
*
* Side effects:
* None.
+ *
*----------------------------------------------------------------------
*/
@@ -393,26 +390,26 @@ SerialGetMilliseconds(void)
*
* SerialSetupProc --
*
- * This procedure is invoked before Tcl_DoOneEvent blocks waiting
- * for an event.
+ * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an
+ * event.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * Adjusts the block time if needed.
+ * Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
SerialSetupProc(
- ClientData data, /* Not used. */
- int flags) /* Event flags as passed to Tcl_DoOneEvent. */
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
int block = 1;
- int msec = INT_MAX; /* min. found block time */
+ int msec = INT_MAX; /* min. found block time */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
@@ -420,7 +417,8 @@ SerialSetupProc(
}
/*
- * Look to see if any events handlers installed. If they are, do not block.
+ * Look to see if any events handlers installed. If they are, do not
+ * block.
*/
for (infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ;
@@ -447,8 +445,8 @@ SerialSetupProc(
*
* SerialCheckProc --
*
- * This procedure is called by Tcl_DoOneEvent to check the serial
- * event source for events.
+ * This procedure is called by Tcl_DoOneEvent to check the serial event
+ * source for events.
*
* Results:
* None.
@@ -461,8 +459,8 @@ SerialSetupProc(
static void
SerialCheckProc(
- ClientData data, /* Not used. */
- int flags) /* Event flags as passed to Tcl_DoOneEvent. */
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
SerialEvent *evPtr;
@@ -489,32 +487,30 @@ SerialCheckProc(
needEvent = 0;
/*
- * If WRITABLE watch mask is set look for infoPtr->evWritable
- * object
+ * If WRITABLE watch mask is set look for infoPtr->evWritable object.
*/
- if (infoPtr->watchMask & TCL_WRITABLE) {
- if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
- infoPtr->writable = 1;
- needEvent = 1;
- }
+ if (infoPtr->watchMask & TCL_WRITABLE &&
+ WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
+ infoPtr->writable = 1;
+ needEvent = 1;
}
/*
- * If READABLE watch mask is set call ClearCommError to poll
- * cbInQue Window errors are ignored here
+ * If READABLE watch mask is set call ClearCommError to poll cbInQue.
+ * Window errors are ignored here.
*/
if (infoPtr->watchMask & TCL_READABLE) {
if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) {
/*
- * Look for characters already pending in windows
- * queue. If they are, poll.
+ * Look for characters already pending in windows queue. If
+ * they are, poll.
*/
if (infoPtr->watchMask & TCL_READABLE) {
/*
- * force fileevent after serial read error
+ * Force fileevent after serial read error.
*/
if ((cStat.cbInQue > 0) ||
@@ -532,8 +528,7 @@ SerialCheckProc(
}
/*
- * Queue an event if the serial is signaled for reading or
- * writing.
+ * Queue an event if the serial is signaled for reading or writing.
*/
if (needEvent) {
@@ -572,9 +567,9 @@ SerialBlockProc(
SerialInfo *infoPtr = (SerialInfo *) instanceData;
/*
- * Only serial READ can be switched between blocking & nonblocking
- * using COMMTIMEOUTS. Serial write emulates blocking &
- * nonblocking by the SerialWriterThread.
+ * Only serial READ can be switched between blocking & nonblocking using
+ * COMMTIMEOUTS. Serial write emulates blocking & nonblocking by the
+ * SerialWriterThread.
*/
if (mode == TCL_MODE_NONBLOCKING) {
@@ -621,42 +616,39 @@ SerialCloseProc(
serialPtr->validMask &= ~TCL_READABLE;
if (serialPtr->validMask & TCL_WRITABLE) {
-
/*
- * Generally we cannot wait for a pending write operation
- * because it may hang due to handshake
+ * Generally we cannot wait for a pending write operation because it
+ * may hang due to handshake
* WaitForSingleObject(serialPtr->evWritable, INFINITE);
*/
/*
- * The thread may have already closed on it's own. Check it's
- * exit code.
+ * The thread may have already closed on it's own. Check it's exit
+ * code.
*/
GetExitCodeThread(serialPtr->writeThread, &exitCode);
if (exitCode == STILL_ACTIVE) {
/*
- * Set the stop event so that if the writer thread is
- * blocked in SerialWriterThread on WaitForMultipleEvents, it
- * will exit cleanly.
+ * Set the stop event so that if the writer thread is blocked in
+ * SerialWriterThread on WaitForMultipleEvents, it will exit
+ * cleanly.
*/
SetEvent(serialPtr->evStopWriter);
/*
- * Wait at most 20 milliseconds for the writer thread to
- * close.
+ * Wait at most 20 milliseconds for the writer thread to close.
*/
- if (WaitForSingleObject(serialPtr->writeThread, 20)
- == WAIT_TIMEOUT) {
+ if (WaitForSingleObject(serialPtr->writeThread,
+ 20) == WAIT_TIMEOUT) {
/*
- * Forcibly terminate the background thread as a last
- * resort. Note that we need to guard against
- * terminating the thread while it is in the middle of
- * Tcl_ThreadAlert because it won't be able to release
- * the notifier lock.
+ * Forcibly terminate the background thread as a last resort.
+ * Note that we need to guard against terminating the thread
+ * while it is in the middle of Tcl_ThreadAlert because it
+ * won't be able to release the notifier lock.
*/
Tcl_MutexLock(&serialMutex);
@@ -681,9 +673,9 @@ SerialCloseProc(
serialPtr->validMask &= ~TCL_WRITABLE;
/*
- * Don't close the Win32 handle if the handle is a standard
- * channel during the thread exit process. Otherwise, one thread
- * may kill the stdio of another.
+ * Don't close the Win32 handle if the handle is a standard channel during
+ * the thread exit process. Otherwise, one thread may kill the stdio of
+ * another.
*/
if (!TclInThreadExit()
@@ -712,8 +704,7 @@ SerialCloseProc(
}
/*
- * Wrap the error file into a channel and give it to the cleanup
- * routine.
+ * Wrap the error file into a channel and give it to the cleanup routine.
*/
if (serialPtr->writeBuf != NULL) {
@@ -733,8 +724,8 @@ SerialCloseProc(
*
* blockingRead --
*
- * Perform a blocking read into the buffer given. Returns count
- * of how many bytes were actually read, and an error indication.
+ * Perform a blocking read into the buffer given. Returns count of how
+ * many bytes were actually read, and an error indication.
*
* Results:
* A count of how many bytes were read is returned and an error
@@ -747,21 +738,21 @@ SerialCloseProc(
*/
static int
-blockingRead(
+blockingRead(
SerialInfo *infoPtr, /* Serial info structure */
LPVOID buf, /* The input buffer pointer */
DWORD bufSize, /* The number of bytes to read */
- LPDWORD lpRead, /* Returns number of bytes read */
+ LPDWORD lpRead, /* Returns number of bytes read */
LPOVERLAPPED osPtr ) /* OVERLAPPED structure */
{
/*
- * Perform overlapped blocking read.
+ * Perform overlapped blocking read.
* 1. Reset the overlapped event
* 2. Start overlapped read operation
* 3. Wait for completion
*/
- /*
+ /*
* Set Offset to ZERO, otherwise NT4.0 may report an error.
*/
@@ -769,16 +760,24 @@ blockingRead(
ResetEvent(osPtr->hEvent);
if (!ReadFile(infoPtr->handle, buf, bufSize, lpRead, osPtr)) {
if (GetLastError() != ERROR_IO_PENDING) {
- /* ReadFile failed, but it isn't delayed. Report error. */
+ /*
+ * ReadFile failed, but it isn't delayed. Report error.
+ */
+
return FALSE;
- } else {
- /* Read is pending, wait for completion, timeout ? */
+ } else {
+ /*
+ * Read is pending, wait for completion, timeout?
+ */
+
if (!GetOverlappedResult(infoPtr->handle, osPtr, lpRead, TRUE)) {
return FALSE;
}
}
} else {
- /* ReadFile completed immediately. */
+ /*
+ * ReadFile completed immediately.
+ */
}
return TRUE;
}
@@ -788,9 +787,8 @@ blockingRead(
*
* blockingWrite --
*
- * Perform a blocking write from the buffer given. Returns count
- * of how many bytes were actually written, and an error
- * indication.
+ * Perform a blocking write from the buffer given. Returns count of how
+ * many bytes were actually written, and an error indication.
*
* Results:
* A count of how many bytes were written is returned and an error
@@ -807,13 +805,13 @@ blockingWrite(
SerialInfo *infoPtr, /* Serial info structure */
LPVOID buf, /* The output buffer pointer */
DWORD bufSize, /* The number of bytes to write */
- LPDWORD lpWritten, /* Returns number of bytes written */
- LPOVERLAPPED osPtr ) /* OVERLAPPED structure */
+ LPDWORD lpWritten, /* Returns number of bytes written */
+ LPOVERLAPPED osPtr) /* OVERLAPPED structure */
{
int result;
/*
- * Perform overlapped blocking write.
+ * Perform overlapped blocking write.
* 1. Reset the overlapped event
* 2. Remove these bytes from the output queue counter
* 3. Start overlapped write operation
@@ -826,32 +824,46 @@ blockingWrite(
EnterCriticalSection(&infoPtr->csWrite);
infoPtr->writeQueue -= bufSize;
- /*
- * Set Offset to ZERO, otherwise NT4.0 may report an error
+
+ /*
+ * Set Offset to ZERO, otherwise NT4.0 may report an error
*/
+
osPtr->Offset = osPtr->OffsetHigh = 0;
result = WriteFile(infoPtr->handle, buf, bufSize, lpWritten, osPtr);
LeaveCriticalSection(&infoPtr->csWrite);
if (result == FALSE) {
int err = GetLastError();
+
switch (err) {
case ERROR_IO_PENDING:
- /* Write is pending, wait for completion */
+ /*
+ * Write is pending, wait for completion.
+ */
+
if (!GetOverlappedResult(infoPtr->handle, osPtr, lpWritten,
TRUE)) {
return FALSE;
}
break;
case ERROR_COUNTER_TIMEOUT:
- /* Write timeout handled in SerialOutputProc */
+ /*
+ * Write timeout handled in SerialOutputProc.
+ */
+
break;
default:
- /* WriteFile failed, but it isn't delayed. Report error */
+ /*
+ * WriteFile failed, but it isn't delayed. Report error.
+ */
+
return FALSE;
}
} else {
- /* WriteFile completed immediately. */
+ /*
+ * WriteFile completed immediately.
+ */
}
EnterCriticalSection(&infoPtr->csWrite);
@@ -866,9 +878,8 @@ blockingWrite(
*
* SerialInputProc --
*
- * Reads input from the IO channel into the buffer given. Returns
- * count of how many bytes were actually read, and an error
- * indication.
+ * Reads input from the IO channel into the buffer given. Returns count
+ * of how many bytes were actually read, and an error indication.
*
* Results:
* A count of how many bytes were read is returned and an error
@@ -884,8 +895,8 @@ static int
SerialInputProc(
ClientData instanceData, /* Serial state. */
char *buf, /* Where to store data read. */
- int bufSize, /* How much space is available
- * in the buffer? */
+ int bufSize, /* How much space is available in the
+ * buffer? */
int *errorCode) /* Where to store error code. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
@@ -903,13 +914,13 @@ SerialInputProc(
}
/*
- * Look for characters already pending in windows queue.
- * This is the mainly restored good old code from Tcl8.0
+ * Look for characters already pending in windows queue. This is the
+ * mainly restored good old code from Tcl8.0
*/
if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) {
/*
- * Check for errors here, but not in the evSetup/Check procedures
+ * Check for errors here, but not in the evSetup/Check procedures.
*/
if (infoPtr->error & SERIAL_READ_ERRORS) {
@@ -917,9 +928,8 @@ SerialInputProc(
}
if (infoPtr->flags & SERIAL_ASYNC) {
/*
- * NON_BLOCKING mode:
- * Avoid blocking by reading more bytes than available
- * in input buffer
+ * NON_BLOCKING mode: Avoid blocking by reading more bytes than
+ * available in input buffer.
*/
if (cStat.cbInQue > 0) {
@@ -932,8 +942,7 @@ SerialInputProc(
}
} else {
/*
- * BLOCKING mode:
- * Tcl trys to read a full buffer of 4 kBytes here
+ * BLOCKING mode: Tcl trys to read a full buffer of 4 kBytes here.
*/
if (cStat.cbInQue > 0) {
@@ -951,24 +960,23 @@ SerialInputProc(
}
/*
- * Perform blocking read. Doesn't block in non-blocking mode,
- * because we checked the number of available bytes.
+ * Perform blocking read. Doesn't block in non-blocking mode, because we
+ * checked the number of available bytes.
*/
+
if (blockingRead(infoPtr, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
&infoPtr->osRead) == FALSE) {
- goto error;
+ TclWinConvertError(GetLastError());
+ *errorCode = errno;
+ return -1;
}
return bytesRead;
- error:
- TclWinConvertError(GetLastError());
- *errorCode = errno;
- return -1;
-
commError:
- infoPtr->lastError = infoPtr->error;/* save last error code */
- infoPtr->error = 0; /* reset error code */
- *errorCode = EIO; /* to return read-error only once */
+ infoPtr->lastError = infoPtr->error;
+ /* save last error code */
+ infoPtr->error = 0; /* reset error code */
+ *errorCode = EIO; /* to return read-error only once */
return -1;
}
@@ -977,13 +985,12 @@ SerialInputProc(
*
* SerialOutputProc --
*
- * Writes the given output on the IO channel. Returns count of
- * how many characters were actually written, and an error
- * indication.
+ * Writes the given output on the IO channel. Returns count of how many
+ * characters were actually written, and an error indication.
*
* Results:
- * A count of how many characters were written is returned and an
- * error indication is returned in an output argument.
+ * A count of how many characters were written is returned and an error
+ * indication is returned in an output argument.
*
* Side effects:
* Writes output on the actual channel.
@@ -1004,9 +1011,9 @@ SerialOutputProc(
*errorCode = 0;
/*
- * At EXIT Tcl trys to flush all open channels in blocking mode.
- * We avoid blocking output after ExitProc or CloseHandler(chan)
- * has been called by checking the corrresponding variables.
+ * At EXIT Tcl trys to flush all open channels in blocking mode. We avoid
+ * blocking output after ExitProc or CloseHandler(chan) has been called by
+ * checking the corrresponding variables.
*/
if (!initialized || TclInExit()) {
@@ -1018,8 +1025,9 @@ SerialOutputProc(
*/
if (infoPtr->error & SERIAL_WRITE_ERRORS) {
- infoPtr->lastError = infoPtr->error; /* save last error code */
- infoPtr->error = 0; /* reset error code */
+ infoPtr->lastError = infoPtr->error;
+ /* save last error code */
+ infoPtr->error = 0; /* reset error code */
errno = EIO;
goto error;
}
@@ -1027,8 +1035,8 @@ SerialOutputProc(
timeout = (infoPtr->flags & SERIAL_ASYNC) ? 0 : INFINITE;
if (WaitForSingleObject(infoPtr->evWritable, timeout) == WAIT_TIMEOUT) {
/*
- * The writer thread is blocked waiting for a write to complete
- * and the channel is in non-blocking mode.
+ * The writer thread is blocked waiting for a write to complete and
+ * the channel is in non-blocking mode.
*/
errno = EWOULDBLOCK;
@@ -1055,8 +1063,8 @@ SerialOutputProc(
if (infoPtr->flags & SERIAL_ASYNC) {
/*
- * The serial is non-blocking, so copy the data into the output
- * buffer and restart the writer thread.
+ * The serial is non-blocking, so copy the data into the output buffer
+ * and restart the writer thread.
*/
if (toWrite > infoPtr->writeBufLen) {
@@ -1078,8 +1086,8 @@ SerialOutputProc(
} else {
/*
- * In the blocking case, just try to write the buffer directly.
- * This avoids an unnecessary copy.
+ * In the blocking case, just try to write the buffer directly. This
+ * avoids an unnecessary copy.
*/
if (!blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite,
@@ -1087,7 +1095,9 @@ SerialOutputProc(
goto writeError;
}
if (bytesWritten != (DWORD) toWrite) {
- /* Write timeout */
+ /*
+ * Write timeout.
+ */
infoPtr->lastError |= CE_PTO;
errno = EIO;
goto error;
@@ -1100,8 +1110,8 @@ SerialOutputProc(
TclWinConvertError(GetLastError());
error:
- /*
- * Reset the output queue counter on error during blocking output
+ /*
+ * Reset the output queue counter on error during blocking output
*/
/*
@@ -1109,7 +1119,7 @@ SerialOutputProc(
* infoPtr->writeQueue = 0;
* LeaveCriticalSection(&infoPtr->csWrite);
*/
- error1:
+ error1:
*errorCode = errno;
return -1;
}
@@ -1119,16 +1129,15 @@ SerialOutputProc(
*
* SerialEventProc --
*
- * This function is invoked by Tcl_ServiceEvent when a file event
- * reaches the front of the event queue. This procedure invokes
- * Tcl_NotifyChannel on the serial.
+ * This function is invoked by Tcl_ServiceEvent when a file event reaches
+ * the front of the event queue. This procedure invokes Tcl_NotifyChannel
+ * on the serial.
*
* 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_FILE_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_FILE_EVENTS flag bit isn't set.
*
* Side effects:
* Whatever the notifier callback does.
@@ -1139,8 +1148,8 @@ SerialOutputProc(
static int
SerialEventProc(
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. */
{
SerialEvent *serialEvPtr = (SerialEvent *)evPtr;
SerialInfo *infoPtr;
@@ -1153,9 +1162,9 @@ SerialEventProc(
/*
* Search through the list of watched serials for the one whose handle
- * matches the event. We do this rather than simply dereferencing
- * the handle in the event so that serials can be deleted while the
- * event is in the queue.
+ * matches the event. We do this rather than simply dereferencing the
+ * handle in the event so that serials can be deleted while the event is
+ * in the queue.
*/
for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
@@ -1175,9 +1184,9 @@ SerialEventProc(
}
/*
- * Check to see if the serial is readable. Note
- * that we can't tell if a serial is writable, so we always report it
- * as being writable unless we have detected EOF.
+ * Check to see if the serial is readable. Note that we can't tell if a
+ * serial is writable, so we always report it as being writable unless we
+ * have detected EOF.
*/
mask = 0;
@@ -1208,8 +1217,7 @@ SerialEventProc(
*
* SerialWatchProc --
*
- * Called by the notifier to set up to watch for events on this
- * channel.
+ * Called by the notifier to set up to watch for events on this channel.
*
* Results:
* None.
@@ -1223,9 +1231,9 @@ SerialEventProc(
static void
SerialWatchProc(
ClientData instanceData, /* Serial state. */
- int mask) /* What events to watch for, OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
+ int mask) /* What events to watch for, OR-ed combination
+ * of TCL_READABLE, TCL_WRITABLE and
+ * TCL_EXCEPTION. */
{
SerialInfo **nextPtrPtr, *ptr;
SerialInfo *infoPtr = (SerialInfo *) instanceData;
@@ -1233,8 +1241,8 @@ SerialWatchProc(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * Since the file is always ready for events, we set the block time
- * so we will poll.
+ * Since the file is always ready for events, we set the block time so we
+ * will poll.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
@@ -1265,12 +1273,12 @@ SerialWatchProc(
*
* SerialGetHandleProc --
*
- * Called from Tcl_GetChannelHandle to retrieve OS handles from
- * inside a command serial port based channel.
+ * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
+ * command serial port based channel.
*
* Results:
- * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
- * there is no handle for the specified direction.
+ * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no
+ * handle for the specified direction.
*
* Side effects:
* None.
@@ -1282,7 +1290,7 @@ static int
SerialGetHandleProc(
ClientData instanceData, /* The serial state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
- ClientData *handlePtr) /* Where to store the handle. */
+ ClientData *handlePtr) /* Where to store the handle. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
@@ -1295,15 +1303,14 @@ SerialGetHandleProc(
*
* SerialWriterThread --
*
- * This function runs in a separate thread and writes data
- * onto a serial.
+ * This function runs in a separate thread and writes data onto a serial.
*
* Results:
- * Always returns 0.
+ * Always returns 0.
*
* Side effects:
- * Signals the main thread when an output operation is completed.
- * May cause the main thread to wake up by posting a message.
+ * Signals the main thread when an output operation is completed. May
+ * cause the main thread to wake up by posting a message.
*
*----------------------------------------------------------------------
*/
@@ -1311,16 +1318,16 @@ SerialGetHandleProc(
static DWORD WINAPI
SerialWriterThread(LPVOID arg)
{
-
SerialInfo *infoPtr = (SerialInfo *)arg;
DWORD bytesWritten, toWrite, waitResult;
char *buf;
- OVERLAPPED myWrite; /* have an own OVERLAPPED in this thread */
+ OVERLAPPED myWrite; /* Have an own OVERLAPPED in this thread. */
HANDLE wEvents[2];
/*
* The stop event takes precedence by being first in the list.
*/
+
wEvents[0] = infoPtr->evStopWriter;
wEvents[1] = infoPtr->evStartWriter;
@@ -1333,8 +1340,8 @@ SerialWriterThread(LPVOID arg)
if (waitResult != (WAIT_OBJECT_0 + 1)) {
/*
- * The start event was not signaled. It might be the stop event
- * or an error, so exit.
+ * The start event was not signaled. It might be the stop event or
+ * an error, so exit.
*/
break;
@@ -1351,20 +1358,23 @@ SerialWriterThread(LPVOID arg)
while (toWrite > 0) {
/*
- * Check for pending writeError. Ignore all write
- * operations until the user has been notified
+ * Check for pending writeError. Ignore all write operations until
+ * the user has been notified.
*/
if (infoPtr->writeError) {
break;
}
- if (blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite,
+ if (blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite,
&bytesWritten, &myWrite) == FALSE) {
infoPtr->writeError = GetLastError();
break;
}
if (bytesWritten != toWrite) {
- /* Write timeout */
+ /*
+ * Write timeout.
+ */
+
infoPtr->writeError = ERROR_WRITE_FAULT;
break;
}
@@ -1375,22 +1385,25 @@ SerialWriterThread(LPVOID arg)
CloseHandle(myWrite.hEvent);
/*
- * Signal the main thread by signalling the evWritable event
- * and then waking up the notifier thread.
+ * Signal the main thread by signalling the evWritable event and then
+ * waking up the notifier thread.
*/
SetEvent(infoPtr->evWritable);
/*
- * Alert the foreground thread. Note that we need to treat
- * this like a critical section so the foreground thread does
- * not terminate this thread while we are holding a mutex in
- * the notifier code.
+ * Alert the foreground thread. Note that we need to treat this like a
+ * critical section so the foreground thread does not terminate this
+ * thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&serialMutex);
if (infoPtr->threadId != NULL) {
- /* TIP #218. When in flight ignore the event, no one will receive it anyway */
+ /*
+ * TIP #218: When in flight ignore the event, no one will receive
+ * it anyway.
+ */
+
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&serialMutex);
@@ -1407,9 +1420,9 @@ SerialWriterThread(LPVOID arg)
* Reopens the serial port with the OVERLAPPED FLAG set
*
* Results:
- * Returns the new handle, or INVALID_HANDLE_VALUE. Normally
- * there shouldn't be any error, because the same channel has
- * previously been succeesfully opened.
+ * Returns the new handle, or INVALID_HANDLE_VALUE. Normally there
+ * shouldn't be any error, because the same channel has previously been
+ * succeesfully opened.
*
* Side effects:
* May close the original handle
@@ -1427,10 +1440,10 @@ TclWinSerialReopen(handle, name, access)
tsdPtr = SerialInit();
- /*
- * Multithreaded I/O needs the overlapped flag set
- * otherwise ClearCommError blocks under Windows NT/2000 until serial
- * output is finished
+ /*
+ * Multithreaded I/O needs the overlapped flag set otherwise
+ * ClearCommError blocks under Windows NT/2000 until serial output is
+ * finished
*/
if (CloseHandle(handle) == FALSE) {
@@ -1446,9 +1459,9 @@ TclWinSerialReopen(handle, name, access)
*
* TclWinOpenSerialChannel --
*
- * Constructs a Serial port channel for the specified standard OS
- * handle. This is a helper function to break up the
- * construction of channels into File, Console, or Serial.
+ * Constructs a Serial port channel for the specified standard OS handle.
+ * This is a helper function to break up the construction of channels
+ * into File, Console, or Serial.
*
* Results:
* Returns the new channel, or NULL.
@@ -1473,22 +1486,22 @@ TclWinOpenSerialChannel(handle, channelName, permissions)
infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo));
memset(infoPtr, 0, sizeof(SerialInfo));
- infoPtr->validMask = permissions;
- infoPtr->handle = handle;
- infoPtr->channel = (Tcl_Channel) NULL;
- infoPtr->readable = 0;
- infoPtr->writable = 1;
- infoPtr->toWrite = infoPtr->writeQueue = 0;
- infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
+ infoPtr->validMask = permissions;
+ infoPtr->handle = handle;
+ infoPtr->channel = (Tcl_Channel) NULL;
+ infoPtr->readable = 0;
+ infoPtr->writable = 1;
+ infoPtr->toWrite = infoPtr->writeQueue = 0;
+ infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
infoPtr->lastEventTime = 0;
- infoPtr->lastError = infoPtr->error = 0;
- infoPtr->threadId = Tcl_GetCurrentThread();
- infoPtr->sysBufRead = 4096;
- infoPtr->sysBufWrite = 4096;
+ infoPtr->lastError = infoPtr->error = 0;
+ infoPtr->threadId = Tcl_GetCurrentThread();
+ infoPtr->sysBufRead = 4096;
+ infoPtr->sysBufWrite = 4096;
/*
- * Use the pointer to keep the channel names unique, in case
- * the handles are shared between multiple channels (stdin/stdout).
+ * Use the pointer to keep the channel names unique, in case the handles
+ * are shared between multiple channels (stdin/stdout).
*/
wsprintfA(channelName, "file%lx", (int) infoPtr);
@@ -1502,7 +1515,7 @@ TclWinOpenSerialChannel(handle, channelName, permissions)
PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR);
/*
- * default is blocking
+ * Default is blocking.
*/
SetCommTimeouts(handle, &no_timeout);
@@ -1511,9 +1524,8 @@ TclWinOpenSerialChannel(handle, channelName, permissions)
infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
}
if (permissions & TCL_WRITABLE) {
- /*
- * Initially the channel is writable
- * and the writeThread is idle.
+ /*
+ * Initially the channel is writable and the writeThread is idle.
*/
infoPtr->osWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
@@ -1526,8 +1538,8 @@ TclWinOpenSerialChannel(handle, channelName, permissions)
}
/*
- * Files have default translation of AUTO and ^Z eof char, which
- * means that a ^Z will be accepted as EOF when reading.
+ * Files have default translation of AUTO and ^Z eof char, which means
+ * that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
@@ -1541,7 +1553,7 @@ TclWinOpenSerialChannel(handle, channelName, permissions)
*
* SerialErrorStr --
*
- * Converts a Win32 serial error code to a list of readable errors
+ * Converts a Win32 serial error code to a list of readable errors.
*
* Results:
* None.
@@ -1554,8 +1566,8 @@ TclWinOpenSerialChannel(handle, channelName, permissions)
static void
SerialErrorStr(error, dsPtr)
- DWORD error; /* Win32 serial error code */
- Tcl_DString *dsPtr; /* Where to store string */
+ DWORD error; /* Win32 serial error code. */
+ Tcl_DString *dsPtr; /* Where to store string. */
{
if (error & CE_RXOVER) {
Tcl_DStringAppendElement(dsPtr, "RXOVER");
@@ -1575,7 +1587,7 @@ SerialErrorStr(error, dsPtr)
if (error & CE_TXFULL) {
Tcl_DStringAppendElement(dsPtr, "TXFULL");
}
- if (error & CE_PTO) { /* PTO used to signal WRITE-TIMEOUT */
+ if (error & CE_PTO) { /* PTO used to signal WRITE-TIMEOUT */
Tcl_DStringAppendElement(dsPtr, "TIMEOUT");
}
if (error & ~((DWORD) (SERIAL_READ_ERRORS | SERIAL_WRITE_ERRORS))) {
@@ -1604,8 +1616,8 @@ SerialErrorStr(error, dsPtr)
static void
SerialModemStatusStr(status, dsPtr)
- DWORD status; /* Win32 modem status */
- Tcl_DString *dsPtr; /* Where to store string */
+ DWORD status; /* Win32 modem status. */
+ Tcl_DString *dsPtr; /* Where to store string. */
{
Tcl_DStringAppendElement(dsPtr, "CTS");
Tcl_DStringAppendElement(dsPtr, (status & MS_CTS_ON) ? "1" : "0");
@@ -1625,8 +1637,8 @@ SerialModemStatusStr(status, dsPtr)
* Sets an option on a channel.
*
* Results:
- * A standard Tcl result. Also sets the interp's result on error
- * if interp is not NULL.
+ * A standard Tcl result. Also sets the interp's result on error if
+ * interp is not NULL.
*
* Side effects:
* May modify an option on a device.
@@ -1652,15 +1664,15 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
infoPtr = (SerialInfo *) instanceData;
- /*
- * Parse options. This would be far easier if we had Tcl_Objs to
- * work with as that would let us use Tcl_GetIndexFromObj()...
+ /*
+ * Parse options. This would be far easier if we had Tcl_Objs to work with
+ * as that would let us use Tcl_GetIndexFromObj()...
*/
len = strlen(optionName);
vlen = strlen(value);
- /*
+ /*
* Option -mode baud,parity,databits,stopbits
*/
@@ -1684,7 +1696,10 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
return TCL_ERROR;
}
- /* Default settings for serial communications */
+ /*
+ * Default settings for serial communications.
+ */
+
dcb.fBinary = TRUE;
dcb.fErrorChar = FALSE;
dcb.fNull = FALSE;
@@ -1699,7 +1714,7 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
return TCL_OK;
}
- /*
+ /*
* Option -handshake none|xonxoff|rtscts|dtrdsr
*/
@@ -1712,8 +1727,7 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
}
/*
- * Reset all handshake options
- * DTR and RTS are ON by default
+ * Reset all handshake options. DTR and RTS are ON by default.
*/
dcb.fOutX = dcb.fInX = FALSE;
@@ -1723,15 +1737,17 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
dcb.fTXContinueOnXoff = FALSE;
/*
- * Adjust the handshake limits.
- * Yes, the XonXoff limits seem to influence even hardware handshake
+ * Adjust the handshake limits. Yes, the XonXoff limits seem to
+ * influence even hardware handshake.
*/
dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);
if (strnicmp(value, "NONE", vlen) == 0) {
- /* leave all handshake options disabled */
+ /*
+ * Leave all handshake options disabled.
+ */
} else if (strnicmp(value, "XONXOFF", vlen) == 0) {
dcb.fOutX = dcb.fInX = TRUE;
} else if (strnicmp(value, "RTSCTS", vlen) == 0) {
@@ -1758,7 +1774,7 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
return TCL_OK;
}
- /*
+ /*
* Option -xchar {\x11 \x13}
*/
@@ -1778,9 +1794,8 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
dcb.XoffChar = argv[1][0];
} else {
if (interp) {
- Tcl_AppendResult(interp,
- "bad value for -xchar: should be a list of two elements",
- (char *) NULL);
+ Tcl_AppendResult(interp, "bad value for -xchar: ",
+ "should be a list of two elements", (char *) NULL);
}
return TCL_ERROR;
}
@@ -1794,7 +1809,7 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
return TCL_OK;
}
- /*
+ /*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
@@ -1855,15 +1870,16 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
return TCL_OK;
}
- /*
+ /*
* Option -sysbuffer {read_size write_size}
- * Option -sysbuffer read_size
+ * Option -sysbuffer read_size
*/
if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) {
/*
* -sysbuffer 4096 or -sysbuffer {64536 4096}
*/
+
size_t inSize = (size_t) -1, outSize = (size_t) -1;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
@@ -1894,9 +1910,9 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
infoPtr->sysBufRead = inSize;
infoPtr->sysBufWrite = outSize;
- /*
- * Adjust the handshake limits. Yes, the XonXoff limits seem
- * to influence even hardware handshake
+ /*
+ * Adjust the handshake limits. Yes, the XonXoff limits seem to
+ * influence even hardware handshake.
*/
if (!GetCommState(infoPtr->handle, &dcb)) {
@@ -1918,7 +1934,7 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
return TCL_OK;
}
- /*
+ /*
* Option -pollinterval msec
*/
@@ -1953,7 +1969,7 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
}
return Tcl_BadChannelOption(interp, optionName,
- "mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
+ "mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
}
/*
@@ -1961,18 +1977,18 @@ SerialSetOptionProc(instanceData, interp, optionName, value)
*
* SerialGetOptionProc --
*
- * Gets a mode associated with an IO channel. If the optionName
- * arg is non NULL, retrieves the value of that option. If the
- * optionName arg is NULL, retrieves a list of alternating option
- * names and values for the given channel.
+ * Gets a mode associated with an IO channel. If the optionName arg is
+ * non NULL, retrieves the value of that option. If the optionName arg is
+ * NULL, retrieves a list of alternating option names and values for the
+ * given channel.
*
* Results:
- * A standard Tcl result. Also sets the supplied DString to the
- * string value of the option(s) returned.
+ * A standard Tcl result. Also sets the supplied DString to the string
+ * value of the option(s) returned.
*
* Side effects:
- * The string returned by this function is in static storage and
- * may be reused at any time subsequent to the call.
+ * The string returned by this function is in static storage and may be
+ * reused at any time subsequent to the call.
*
*----------------------------------------------------------------------
*/
@@ -1987,7 +2003,7 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
SerialInfo *infoPtr;
DCB dcb;
size_t len;
- int valid = 0; /* flag if valid option parsed */
+ int valid = 0; /* Flag if valid option parsed. */
infoPtr = (SerialInfo *) instanceData;
@@ -1998,7 +2014,7 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
}
/*
- * get option -mode
+ * Get option -mode
*/
if (len == 0) {
@@ -2030,7 +2046,7 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
}
/*
- * get option -pollinterval
+ * Get option -pollinterval
*/
if (len == 0) {
@@ -2045,7 +2061,7 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
}
/*
- * get option -sysbuffer
+ * Get option -sysbuffer
*/
if (len == 0) {
@@ -2066,7 +2082,7 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
}
/*
- * get option -xchar
+ * Get option -xchar
*/
if (len == 0) {
@@ -2093,9 +2109,10 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
}
/*
- * get option -lasterror
- * option is readonly and returned by [fconfigure chan -lasterror]
- * but not returned by unnamed [fconfigure chan]
+ * Get option -lasterror
+ *
+ * Option is readonly and returned by [fconfigure chan -lasterror] but not
+ * returned by unnamed [fconfigure chan].
*/
if (len>1 && strncmp(optionName, "-lasterror", len)==0) {
@@ -2105,7 +2122,8 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
/*
* get option -queue
- * option is readonly and returned by [fconfigure chan -queue]
+ *
+ * Option is readonly and returned by [fconfigure chan -queue].
*/
if (len>1 && strncmp(optionName, "-queue", len)==0) {
@@ -2117,7 +2135,7 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
valid = 1;
/*
- * Query the pending data in Tcl's internal queues
+ * Query the pending data in Tcl's internal queues.
*/
inBuffered = Tcl_InputBuffered(infoPtr->channel);
@@ -2135,16 +2153,17 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
count = (int)cStat.cbOutQue + infoPtr->writeQueue;
LeaveCriticalSection(&infoPtr->csWrite);
- wsprintfA(buf, "%d", inBuffered + cStat.cbInQue);
+ wsprintfA(buf, "%d", inBuffered + cStat.cbInQue);
Tcl_DStringAppendElement(dsPtr, buf);
- wsprintfA(buf, "%d", outBuffered + count);
+ wsprintfA(buf, "%d", outBuffered + count);
Tcl_DStringAppendElement(dsPtr, buf);
}
/*
* get option -ttystatus
- * option is readonly and returned by [fconfigure chan -ttystatus]
- * but not returned by unnamed [fconfigure chan]
+ *
+ * Option is readonly and returned by [fconfigure chan -ttystatus] but not
+ * returned by unnamed [fconfigure chan].
*/
if (len>4 && strncmp(optionName, "-ttystatus", len)==0) {
@@ -2185,33 +2204,43 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
*/
static void
-SerialThreadActionProc (instanceData, action)
- ClientData instanceData;
- int action;
+SerialThreadActionProc(instanceData, action)
+ ClientData instanceData;
+ int action;
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
- /* We do not access firstSerialPtr in the thread structures. This is
- * not for all serials managed by the thread, but only those we are
- * watching. Removal of the filevent handlers before transfer thus
- * takes care of this structure.
+ /*
+ * We do not access firstSerialPtr in the thread structures. This is not
+ * for all serials managed by the thread, but only those we are watching.
+ * Removal of the filevent handlers before transfer thus takes care of
+ * this structure.
*/
Tcl_MutexLock(&serialMutex);
if (action == TCL_CHANNEL_THREAD_INSERT) {
- /* We can't copy the thread information from the channel when
- * the channel is created. At this time the channel back
- * pointer has not been set yet. However in that case the
- * threadId has already been set by TclpCreateCommandChannel
- * itself, so the structure is still good.
+ /*
+ * We can't copy the thread information from the channel when the
+ * channel is created. At this time the channel back pointer has not
+ * been set yet. However in that case the threadId has already been
+ * set by TclpCreateCommandChannel itself, so the structure is still
+ * good.
*/
- SerialInit ();
- if (infoPtr->channel != NULL) {
- infoPtr->threadId = Tcl_GetChannelThread (infoPtr->channel);
+ SerialInit();
+ if (infoPtr->channel != NULL) {
+ infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&serialMutex);
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index 8af394b..10c24bd 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -1,22 +1,23 @@
-/*
+/*
* tclWinSock.c --
*
* This file contains Windows-specific socket related code.
*
* Copyright (c) 1995-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: tclWinSock.c,v 1.47 2005/07/13 20:01:02 dgp Exp $
+ * RCS: @(#) $Id: tclWinSock.c,v 1.48 2005/07/24 22:56:50 dkf Exp $
*/
#include "tclWinInt.h"
/*
- * Make sure to remove the redirection defines set in tclWinPort.h
- * that is in use in other sections of the core, except for us.
+ * Make sure to remove the redirection defines set in tclWinPort.h that is in
+ * use in other sections of the core, except for us.
*/
+
#undef getservbyname
#undef getsockopt
#undef ntohs
@@ -34,7 +35,7 @@ TCL_DECLARE_MUTEX(socketMutex)
* The following variable holds the network name of this host.
*/
-static TclInitProcessGlobalValueProc InitializeHostName;
+static TclInitProcessGlobalValueProc InitializeHostName;
static ProcessGlobalValue hostName =
{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};
@@ -44,62 +45,62 @@ static ProcessGlobalValue hostName =
#ifdef HAVE_NO_LPFN_DECLS
typedef SOCKET (PASCAL FAR *LPFN_ACCEPT)(SOCKET s,
- struct sockaddr FAR * addr, int FAR * addrlen);
+ struct sockaddr FAR * addr, int FAR * addrlen);
typedef int (PASCAL FAR *LPFN_BIND)(SOCKET s,
- const struct sockaddr FAR *addr, int namelen);
+ const struct sockaddr FAR *addr, int namelen);
typedef int (PASCAL FAR *LPFN_CLOSESOCKET)(SOCKET s);
typedef int (PASCAL FAR *LPFN_CONNECT)(SOCKET s,
- const struct sockaddr FAR *name, int namelen);
+ const struct sockaddr FAR *name, int namelen);
typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYADDR)
- (const char FAR *addr, int addrlen, int addrtype);
+ (const char FAR *addr, int addrlen, int addrtype);
typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYNAME)
- (const char FAR * name);
+ (const char FAR * name);
typedef int (PASCAL FAR *LPFN_GETHOSTNAME)(char FAR * name,
- int namelen);
+ int namelen);
typedef int (PASCAL FAR *LPFN_GETPEERNAME)(SOCKET sock,
- struct sockaddr FAR *name, int FAR *namelen);
+ struct sockaddr FAR *name, int FAR *namelen);
typedef struct servent FAR * (PASCAL FAR *LPFN_GETSERVBYNAME)
- (const char FAR * name, const char FAR * proto);
+ (const char FAR * name, const char FAR * proto);
typedef int (PASCAL FAR *LPFN_GETSOCKNAME)(SOCKET sock,
- struct sockaddr FAR *name, int FAR *namelen);
+ struct sockaddr FAR *name, int FAR *namelen);
typedef int (PASCAL FAR *LPFN_GETSOCKOPT)(SOCKET s, int level,
- int optname, char FAR * optval, int FAR *optlen);
+ int optname, char FAR * optval, int FAR *optlen);
typedef u_short (PASCAL FAR *LPFN_HTONS)(u_short hostshort);
typedef unsigned long (PASCAL FAR *LPFN_INET_ADDR)
- (const char FAR * cp);
+ (const char FAR * cp);
typedef char FAR * (PASCAL FAR *LPFN_INET_NTOA)
- (struct in_addr in);
+ (struct in_addr in);
typedef int (PASCAL FAR *LPFN_IOCTLSOCKET)(SOCKET s,
- long cmd, u_long FAR *argp);
+ long cmd, u_long FAR *argp);
typedef int (PASCAL FAR *LPFN_LISTEN)(SOCKET s, int backlog);
typedef u_short (PASCAL FAR *LPFN_NTOHS)(u_short netshort);
typedef int (PASCAL FAR *LPFN_RECV)(SOCKET s, char FAR * buf,
- int len, int flags);
+ int len, int flags);
typedef int (PASCAL FAR *LPFN_SELECT)(int nfds,
- fd_set FAR * readfds, fd_set FAR * writefds,
- fd_set FAR * exceptfds,
- const struct timeval FAR * timeout);
+ fd_set FAR * readfds, fd_set FAR * writefds,
+ fd_set FAR * exceptfds,
+ const struct timeval FAR * timeout);
typedef int (PASCAL FAR *LPFN_SEND)(SOCKET s,
- const char FAR * buf, int len, int flags);
+ const char FAR * buf, int len, int flags);
typedef int (PASCAL FAR *LPFN_SETSOCKOPT)(SOCKET s,
- int level, int optname, const char FAR * optval,
- int optlen);
+ int level, int optname, const char FAR * optval,
+ int optlen);
typedef SOCKET (PASCAL FAR *LPFN_SOCKET)(int af,
- int type, int protocol);
+ int type, int protocol);
typedef int (PASCAL FAR *LPFN_WSAASYNCSELECT)(SOCKET s,
- HWND hWnd, u_int wMsg, long lEvent);
+ HWND hWnd, u_int wMsg, long lEvent);
typedef int (PASCAL FAR *LPFN_WSACLEANUP)(void);
typedef int (PASCAL FAR *LPFN_WSAGETLASTERROR)(void);
typedef int (PASCAL FAR *LPFN_WSASTARTUP)(WORD wVersionRequired,
- LPWSADATA lpWSAData);
+ LPWSADATA lpWSAData);
#endif
/*
- * The following structure contains pointers to all of the WinSock API
- * entry points used by Tcl. It is initialized by InitSockets. Since
- * we dynamically load the Winsock DLL on demand, we must use this
- * function table to refer to functions in the winsock API.
+ * The following structure contains pointers to all of the WinSock API entry
+ * points used by Tcl. It is initialized by InitSockets. Since we dynamically
+ * load the Winsock DLL on demand, we must use this function table to refer to
+ * functions in the winsock API.
*/
static struct {
@@ -132,7 +133,6 @@ static struct {
LPFN_WSACLEANUP WSACleanup;
LPFN_WSAGETLASTERROR WSAGetLastError;
LPFN_WSASTARTUP WSAStartup;
-
} winSock;
/*
@@ -146,52 +146,48 @@ static struct {
#define UNSELECT FALSE
/*
- * The following structure is used to store the data associated with
- * each socket.
+ * The following structure is used to store the data associated with each
+ * socket.
*/
typedef struct SocketInfo {
- Tcl_Channel channel; /* Channel associated with this
- * socket. */
- SOCKET socket; /* Windows SOCKET handle. */
- int flags; /* Bit field comprised of the flags
- * described below. */
- int watchEvents; /* OR'ed combination of FD_READ,
- * FD_WRITE, FD_CLOSE, FD_ACCEPT and
- * FD_CONNECT that indicate which
- * events are interesting. */
- int readyEvents; /* OR'ed combination of FD_READ,
- * FD_WRITE, FD_CLOSE, FD_ACCEPT and
- * FD_CONNECT that indicate which
- * events have occurred. */
- int selectEvents; /* OR'ed combination of FD_READ,
- * FD_WRITE, FD_CLOSE, FD_ACCEPT and
- * FD_CONNECT that indicate which
- * events are currently being
- * selected. */
- int acceptEventCount; /* Count of the current number of
- * FD_ACCEPTs that have arrived and
- * not yet processed. */
- Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */
- ClientData acceptProcData; /* The data for the accept proc. */
- int lastError; /* Error code from last message. */
- struct SocketInfo *nextPtr; /* The next socket on the per-thread
- * socket list. */
+ Tcl_Channel channel; /* Channel associated with this socket. */
+ SOCKET socket; /* Windows SOCKET handle. */
+ int flags; /* Bit field comprised of the flags described
+ * below. */
+ int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE,
+ * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
+ * indicate which events are interesting. */
+ int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE,
+ * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
+ * indicate which events have occurred. */
+ int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE,
+ * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
+ * indicate which events are currently being
+ * selected. */
+ int acceptEventCount; /* Count of the current number of FD_ACCEPTs
+ * that have arrived and not yet processed. */
+ Tcl_TcpAcceptProc *acceptProc;
+ /* Proc to call on accept. */
+ ClientData acceptProcData; /* The data for the accept proc. */
+ int lastError; /* Error code from last message. */
+ struct SocketInfo *nextPtr; /* The next socket on the per-thread socket
+ * list. */
} SocketInfo;
/*
- * The following structure is what is added to the Tcl event queue when
- * a socket event occurs.
+ * The following structure is what is added to the Tcl event queue when a
+ * socket event occurs.
*/
typedef struct SocketEvent {
- Tcl_Event header; /* Information that is standard for
- * all events. */
- SOCKET socket; /* Socket descriptor that is ready. Used
- * to find the SocketInfo structure for
- * the file (can't point directly to the
- * SocketInfo structure because it could
- * go away while the event is queued). */
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ SOCKET socket; /* Socket descriptor that is ready. Used to
+ * find the SocketInfo structure for the file
+ * (can't point directly to the SocketInfo
+ * structure because it could go away while
+ * the event is queued). */
} SocketEvent;
/*
@@ -201,30 +197,28 @@ typedef struct SocketEvent {
#define TCP_BUFFER_SIZE 4096
/*
- * The following macros may be used to set the flags field of
- * a SocketInfo structure.
+ * The following macros may be used to set the flags field of a SocketInfo
+ * structure.
*/
-#define SOCKET_ASYNC (1<<0) /* The socket is in blocking
- * mode. */
-#define SOCKET_EOF (1<<1) /* A zero read happened on
- * the socket. */
-#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async
- * connect. */
-#define SOCKET_PENDING (1<<3) /* A message has been sent
- * for this socket */
+#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */
+#define SOCKET_EOF (1<<1) /* A zero read happened on the
+ * socket. */
+#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */
+#define SOCKET_PENDING (1<<3) /* A message has been sent for this
+ * socket */
typedef struct ThreadSpecificData {
- HWND hwnd; /* Handle to window for socket messages. */
- HANDLE socketThread; /* Thread handling the window */
- Tcl_ThreadId threadId; /* Parent thread. */
- HANDLE readyEvent; /* Event indicating that a socket event is
- * ready. Also used to indicate that the
- * socketThread has been initialized and has
- * started. */
- HANDLE socketListLock; /* Win32 Event to lock the socketList */
- SocketInfo *socketList; /* Every open socket in this thread has an
- * entry on this list. */
+ HWND hwnd; /* Handle to window for socket messages. */
+ HANDLE socketThread; /* Thread handling the window */
+ Tcl_ThreadId threadId; /* Parent thread. */
+ HANDLE readyEvent; /* Event indicating that a socket event is
+ * ready. Also used to indicate that the
+ * socketThread has been initialized and has
+ * started. */
+ HANDLE socketListLock; /* Win32 Event to lock the socketList */
+ SocketInfo *socketList; /* Every open socket in this thread has an
+ * entry on this list. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
@@ -234,26 +228,28 @@ static WNDCLASS windowClass;
* Static functions defined in this file.
*/
-static SocketInfo * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp,
- int port, CONST char *host,
- int server, CONST char *myaddr,
- int myport, int async));
-static int CreateSocketAddress _ANSI_ARGS_(
- (LPSOCKADDR_IN sockaddrPtr,
- CONST char *host, int port));
-static void InitSockets _ANSI_ARGS_((void));
-static SocketInfo * NewSocketInfo _ANSI_ARGS_((SOCKET socket));
-static Tcl_EventCheckProc SocketCheckProc;
-static Tcl_EventProc SocketEventProc;
-static void SocketExitHandler _ANSI_ARGS_((
- ClientData clientData));
-static LRESULT CALLBACK SocketProc _ANSI_ARGS_((HWND hwnd,
- UINT message, WPARAM wParam,
- LPARAM lParam));
-static Tcl_EventSetupProc SocketSetupProc;
-static Tcl_ExitProc SocketThreadExitHandler;
-static int SocketsEnabled _ANSI_ARGS_((void));
-static void TcpAccept _ANSI_ARGS_((SocketInfo *infoPtr));
+static SocketInfo * CreateSocket(Tcl_Interp *interp, int port,
+ CONST char *host, int server, CONST char *myaddr,
+ int myport, int async);
+static int CreateSocketAddress(LPSOCKADDR_IN sockaddrPtr,
+ CONST char *host, int port);
+static void InitSockets(void);
+static SocketInfo * NewSocketInfo(SOCKET socket);
+static void SocketExitHandler(ClientData clientData);
+static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam,
+ LPARAM lParam);
+static int SocketsEnabled(void);
+static void TcpAccept(SocketInfo *infoPtr);
+static int WaitForSocketEvent(SocketInfo *infoPtr, int events,
+ int *errorCodePtr);
+static DWORD WINAPI SocketThread(LPVOID arg);
+static void TcpThreadActionProc(ClientData instanceData,
+ int action);
+
+static Tcl_EventCheckProc SocketCheckProc;
+static Tcl_EventProc SocketEventProc;
+static Tcl_EventSetupProc SocketSetupProc;
+static Tcl_ExitProc SocketThreadExitHandler;
static Tcl_DriverBlockModeProc TcpBlockProc;
static Tcl_DriverCloseProc TcpCloseProc;
static Tcl_DriverSetOptionProc TcpSetOptionProc;
@@ -262,14 +258,6 @@ static Tcl_DriverInputProc TcpInputProc;
static Tcl_DriverOutputProc TcpOutputProc;
static Tcl_DriverWatchProc TcpWatchProc;
static Tcl_DriverGetHandleProc TcpGetHandleProc;
-static int WaitForSocketEvent _ANSI_ARGS_((
- SocketInfo *infoPtr, int events,
- int *errorCodePtr));
-static DWORD WINAPI SocketThread _ANSI_ARGS_((LPVOID arg));
-
-static void TcpThreadActionProc _ANSI_ARGS_ ((
- ClientData instanceData, int action));
-
/*
* This structure describes the channel type structure for TCP socket
@@ -291,7 +279,7 @@ static Tcl_ChannelType tcpChannelType = {
TcpBlockProc, /* Set socket into (non-)blocking mode. */
NULL, /* flush proc. */
NULL, /* handler proc. */
- NULL, /* wide seek proc */
+ NULL, /* wide seek proc */
TcpThreadActionProc, /* thread action proc */
};
@@ -301,9 +289,9 @@ static Tcl_ChannelType tcpChannelType = {
*
* InitSockets --
*
- * Initialize the socket module. Attempts to load the wsock32.dll
- * library and set up the winSock function table. If successful,
- * registers the event window for the socket notifier code.
+ * Initialize the socket module. Attempts to load the wsock32.dll library
+ * and set up the winSock function table. If successful, registers the
+ * event window for the socket notifier code.
*
* Assumes Mutex is held.
*
@@ -311,9 +299,8 @@ static Tcl_ChannelType tcpChannelType = {
* None.
*
* Side effects:
- * Dynamically loads wsock32.dll, and registers a new window
- * class and creates a window for use in asynchronous socket
- * notification.
+ * Dynamically loads wsock32.dll, and registers a new window class and
+ * creates a window for use in asynchronous socket notification.
*
*----------------------------------------------------------------------
*/
@@ -324,8 +311,8 @@ InitSockets()
DWORD id;
WSADATA wsaData;
DWORD err;
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ TclThreadDataKeyGet(&dataKey);
if (!initialized) {
initialized = 1;
@@ -336,7 +323,7 @@ InitSockets()
if (winSock.hModule == NULL) {
return;
}
-
+
/*
* Initialize the function table.
*/
@@ -393,13 +380,12 @@ InitSockets()
GetProcAddress(winSock.hModule, "WSAGetLastError");
winSock.WSAStartup = (LPFN_WSASTARTUP)
GetProcAddress(winSock.hModule, "WSAStartup");
-
+
/*
- * Now check that all fields are properly initialized. If not,
- * return zero to indicate that we failed to initialize
- * properly.
+ * Now check that all fields are properly initialized. If not, return
+ * zero to indicate that we failed to initialize properly.
*/
-
+
if ((winSock.accept == NULL) ||
(winSock.bind == NULL) ||
(winSock.closesocket == NULL) ||
@@ -425,18 +411,17 @@ InitSockets()
(winSock.WSAAsyncSelect == NULL) ||
(winSock.WSACleanup == NULL) ||
(winSock.WSAGetLastError == NULL) ||
- (winSock.WSAStartup == NULL))
- {
+ (winSock.WSAStartup == NULL)) {
goto unloadLibrary;
}
-
+
/*
- * Create the async notification window with a new class. We
- * must create a new class to avoid a Windows 95 bug that causes
- * us to get the wrong message number for socket events if the
- * message window is a subclass of a static control.
+ * Create the async notification window with a new class. We must
+ * create a new class to avoid a Windows 95 bug that causes us to get
+ * the wrong message number for socket events if the message window is
+ * a subclass of a static control.
*/
-
+
windowClass.style = 0;
windowClass.cbClsExtra = 0;
windowClass.cbWndExtra = 0;
@@ -454,14 +439,14 @@ InitSockets()
}
/*
- * Initialize the winsock library and check the interface
- * version actually loaded. We only ask for the 1.1 interface
- * and do require that it not be less than 1.1.
+ * Initialize the winsock library and check the interface version
+ * actually loaded. We only ask for the 1.1 interface and do require
+ * that it not be less than 1.1.
*/
-#define WSA_VERSION_MAJOR 1
-#define WSA_VERSION_MINOR 1
-#define WSA_VERSION_REQD MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR)
+#define WSA_VERSION_MAJOR 1
+#define WSA_VERSION_MINOR 1
+#define WSA_VERSION_REQD MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR)
if ((err = winSock.WSAStartup(WSA_VERSION_REQD, &wsaData)) != 0) {
TclWinConvertWSAError(err);
@@ -469,9 +454,9 @@ InitSockets()
}
/*
- * Note the byte positions are swapped for the comparison, so
- * that 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101
- * (1.1). We want the comparison to be 0x0200 < 0x0101.
+ * Note the byte positions are swapped for the comparison, so that
+ * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1).
+ * We want the comparison to be 0x0200 < 0x0101.
*/
if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion))
@@ -496,7 +481,7 @@ InitSockets()
tsdPtr->hwnd = NULL;
tsdPtr->threadId = Tcl_GetCurrentThread();
-
+
tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread,
@@ -506,29 +491,27 @@ InitSockets()
if (tsdPtr->socketThread == NULL) {
goto unloadLibrary;
}
-
+
/*
- * Wait for the thread to signal that the window has
- * been created and is ready to go. Timeout after twenty
- * seconds.
+ * Wait for the thread to signal that the window has been created and
+ * is ready to go. Timeout after twenty seconds.
*/
-
- if (WaitForSingleObject(tsdPtr->readyEvent, 20000)
- == WAIT_TIMEOUT) {
+
+ if (WaitForSingleObject(tsdPtr->readyEvent, 20000) == WAIT_TIMEOUT) {
goto unloadLibrary;
}
if (tsdPtr->hwnd == NULL) {
goto unloadLibrary;
}
-
+
Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
Tcl_CreateThreadExitHandler(SocketThreadExitHandler, NULL);
}
return;
-unloadLibrary:
+ unloadLibrary:
if (tsdPtr != NULL && tsdPtr->hwnd != NULL) {
SocketThreadExitHandler(0);
}
@@ -585,14 +568,15 @@ SocketsEnabled()
/* ARGSUSED */
static void
SocketExitHandler(clientData)
- ClientData clientData; /* Not used. */
+ ClientData clientData; /* Not used. */
{
Tcl_MutexLock(&socketMutex);
if (winSock.hModule) {
/*
- * Make sure the socket event handling window is cleaned-up
- * for, at most, this thread.
+ * Make sure the socket event handling window is cleaned-up for, at
+ * most, this thread.
*/
+
SocketThreadExitHandler(clientData);
UnregisterClass("TclSocket", TclWinGetTclInstance());
winSock.WSACleanup();
@@ -608,8 +592,8 @@ SocketExitHandler(clientData)
*
* SocketThreadExitHandler --
*
- * Callback invoked during thread clean up to delete the socket
- * event source.
+ * Callback invoked during thread clean up to delete the socket event
+ * source.
*
* Results:
* None.
@@ -623,9 +607,9 @@ SocketExitHandler(clientData)
/* ARGSUSED */
static void
SocketThreadExitHandler(clientData)
- ClientData clientData; /* Not used. */
+ ClientData clientData; /* Not used. */
{
- ThreadSpecificData *tsdPtr =
+ ThreadSpecificData *tsdPtr =
(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL && tsdPtr->socketThread != NULL) {
@@ -634,11 +618,12 @@ SocketThreadExitHandler(clientData)
GetExitCodeThread(tsdPtr->socketThread, &exitCode);
if (exitCode == STILL_ACTIVE) {
PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);
+
/*
- * Wait for the thread to close. This ensures that we are
- * completely cleaned up before we leave this function.
- * If Tcl_Finalize was called from DllMain, the thread
- * is in a paused state so we need to timeout and continue.
+ * Wait for the thread to close. This ensures that we are
+ * completely cleaned up before we leave this function. If
+ * Tcl_Finalize was called from DllMain, the thread is in a paused
+ * state so we need to timeout and continue.
*/
WaitForSingleObject(tsdPtr->socketThread, 100);
@@ -658,18 +643,18 @@ SocketThreadExitHandler(clientData)
*
* TclpHasSockets --
*
- * This function determines whether sockets are available on the
- * current system and returns an error in interp if they are not.
- * Note that interp may be NULL.
+ * This function determines whether sockets are available on the current
+ * system and returns an error in interp if they are not. Note that
+ * interp may be NULL.
*
* Results:
- * Returns TCL_OK if the system supports sockets, or TCL_ERROR with
- * an error in interp.
+ * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an
+ * error in interp (if non-NULL).
*
* Side effects:
- * If not already prepared, initializes the TSD structure and
- * socket message handling thread associated to the calling thread
- * for the subsystem of the driver.
+ * If not already prepared, initializes the TSD structure and socket
+ * message handling thread associated to the calling thread for the
+ * subsystem of the driver.
*
*----------------------------------------------------------------------
*/
@@ -697,8 +682,8 @@ TclpHasSockets(interp)
*
* SocketSetupProc --
*
- * This procedure is invoked before Tcl_DoOneEvent blocks waiting
- * for an event.
+ * This function is invoked before Tcl_DoOneEvent blocks waiting for an
+ * event.
*
* Results:
* None.
@@ -721,13 +706,13 @@ SocketSetupProc(data, flags)
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
-
+
/*
- * Check to see if there is a ready socket. If so, poll.
+ * Check to see if there is a ready socket. If so, poll.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
+ for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->readyEvents & infoPtr->watchEvents) {
Tcl_SetMaxBlockTime(&blockTime);
@@ -742,8 +727,8 @@ SocketSetupProc(data, flags)
*
* SocketCheckProc --
*
- * This procedure is called by Tcl_DoOneEvent to check the socket
- * event source for events.
+ * This function is called by Tcl_DoOneEvent to check the socket event
+ * source for events.
*
* Results:
* None.
@@ -766,7 +751,7 @@ SocketCheckProc(data, flags)
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
-
+
/*
* Queue events for any ready sockets that don't already have events
* queued (caused by persistent states that won't generate WinSock
@@ -774,7 +759,7 @@ SocketCheckProc(data, flags)
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
+ for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if ((infoPtr->readyEvents & infoPtr->watchEvents)
&& !(infoPtr->flags & SOCKET_PENDING)) {
@@ -793,18 +778,18 @@ SocketCheckProc(data, flags)
*
* SocketEventProc --
*
- * This procedure is called by Tcl_ServiceEvent when a socket event
- * reaches the front of the event queue. This procedure is
- * responsible for notifying the generic channel code.
+ * This function is called by Tcl_ServiceEvent when a socket event
+ * reaches the front of the event queue. This function is responsible for
+ * notifying the generic channel code.
*
* 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_FILE_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_FILE_EVENTS flag bit isn't set.
*
* Side effects:
- * Whatever the channel callback procedures do.
+ * Whatever the channel callback functions do.
*
*----------------------------------------------------------------------
*/
@@ -812,8 +797,8 @@ SocketCheckProc(data, flags)
static int
SocketEventProc(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. */
{
SocketInfo *infoPtr;
SocketEvent *eventPtr = (SocketEvent *) evPtr;
@@ -830,7 +815,7 @@ SocketEventProc(evPtr, flags)
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
+ for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->socket == eventPtr->socket) {
break;
@@ -858,21 +843,21 @@ SocketEventProc(evPtr, flags)
}
/*
- * Mask off unwanted events and compute the read/write mask so
- * we can notify the channel.
+ * Mask off unwanted events and compute the read/write mask so we can
+ * notify the channel.
*/
events = infoPtr->readyEvents & infoPtr->watchEvents;
if (events & FD_CLOSE) {
/*
- * If the socket was closed and the channel is still interested
- * in read events, then we need to ensure that we keep polling
- * for this event until someone does something with the channel.
- * Note that we do this before calling Tcl_NotifyChannel so we don't
- * have to watch out for the channel being deleted out from under
- * us. This may cause a redundant trip through the event loop, but
- * it's simpler than trying to do unwind protection.
+ * If the socket was closed and the channel is still interested in
+ * read events, then we need to ensure that we keep polling for this
+ * event until someone does something with the channel. Note that we
+ * do this before calling Tcl_NotifyChannel so we don't have to watch
+ * out for the channel being deleted out from under us. This may cause
+ * a redundant trip through the event loop, but it's simpler than
+ * trying to do unwind protection.
*/
Tcl_Time blockTime = { 0, 0 };
@@ -884,10 +869,10 @@ SocketEventProc(evPtr, flags)
/*
* We must check to see if data is really available, since someone
- * could have consumed the data in the meantime. Turn off async
- * notification so select will work correctly. If the socket is
- * still readable, notify the channel driver, otherwise reset the
- * async select handler and keep waiting.
+ * could have consumed the data in the meantime. Turn off async
+ * notification so select will work correctly. If the socket is still
+ * readable, notify the channel driver, otherwise reset the async
+ * select handler and keep waiting.
*/
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
@@ -897,7 +882,7 @@ SocketEventProc(evPtr, flags)
FD_SET(infoPtr->socket, &readFds);
timeout.tv_usec = 0;
timeout.tv_sec = 0;
-
+
if (winSock.select(0, &readFds, NULL, NULL, &timeout) != 0) {
mask |= TCL_READABLE;
} else {
@@ -909,7 +894,10 @@ SocketEventProc(evPtr, flags)
if (events & (FD_WRITE | FD_CONNECT)) {
mask |= TCL_WRITABLE;
if (events & FD_CONNECT && infoPtr->lastError != NO_ERROR) {
- /* connect errors should also fire the readable handler. */
+ /*
+ * Connect errors should also fire the readable handler.
+ */
+
mask |= TCL_READABLE;
}
}
@@ -940,7 +928,7 @@ static int
TcpBlockProc(instanceData, mode)
ClientData instanceData; /* The socket to block/un-block. */
int mode; /* TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
+ * TCL_MODE_NONBLOCKING. */
{
SocketInfo *infoPtr = (SocketInfo *) instanceData;
@@ -957,9 +945,9 @@ TcpBlockProc(instanceData, mode)
*
* TcpCloseProc --
*
- * This procedure is called by the generic IO level to perform
- * channel type specific cleanup on a socket based channel
- * when the channel is closed.
+ * This function is called by the generic IO level to perform channel
+ * type specific cleanup on a socket based channel when the channel is
+ * closed.
*
* Results:
* 0 if successful, the value of errno if failed.
@@ -982,32 +970,31 @@ TcpCloseProc(instanceData, interp)
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
if (SocketsEnabled()) {
-
/*
- * Clean up the OS socket handle. The default Windows setting
- * for a socket is SO_DONTLINGER, which does a graceful shutdown
- * in the background.
- */
-
- if (winSock.closesocket(infoPtr->socket) == SOCKET_ERROR) {
- TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
- errorCode = Tcl_GetErrno();
- }
- }
-
- /* TIP #218. Removed the code removing the structure
- * from the global socket list. This is now done by
- * the thread action callbacks, and only there. This
- * happens before this code is called. We can free
- * without fear of damaging the list.
+ * Clean up the OS socket handle. The default Windows setting for a
+ * socket is SO_DONTLINGER, which does a graceful shutdown in the
+ * background.
+ */
+
+ if (winSock.closesocket(infoPtr->socket) == SOCKET_ERROR) {
+ TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
+ errorCode = Tcl_GetErrno();
+ }
+ }
+
+ /*
+ * TIP #218. Removed the code removing the structure from the global
+ * socket list. This is now done by the thread action callbacks, and only
+ * there. This happens before this code is called. We can free without
+ * fear of damaging the list.
*/
+
ckfree((char *) infoPtr);
return errorCode;
}
@@ -1017,8 +1004,7 @@ TcpCloseProc(instanceData, interp)
*
* NewSocketInfo --
*
- * This function allocates and initializes a new SocketInfo
- * structure.
+ * This function allocates and initializes a new SocketInfo structure.
*
* Results:
* Returns a newly allocated SocketInfo.
@@ -1048,10 +1034,12 @@ NewSocketInfo(socket)
infoPtr->acceptProcData = NULL;
infoPtr->lastError = 0;
- /* TIP #218. Removed the code inserting the new structure
- * into the global list. This is now handled in the thread
- * action callbacks, and only there.
+ /*
+ * TIP #218. Removed the code inserting the new structure into the global
+ * list. This is now handled in the thread action callbacks, and only
+ * there.
*/
+
infoPtr->nextPtr = NULL;
return infoPtr;
@@ -1062,8 +1050,8 @@ NewSocketInfo(socket)
*
* CreateSocket --
*
- * This function opens a new socket and initializes the
- * SocketInfo structure.
+ * This function opens a new socket and initializes the SocketInfo
+ * structure.
*
* Results:
* Returns a new SocketInfo, or NULL with an error in interp.
@@ -1079,39 +1067,38 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
Tcl_Interp *interp; /* For error reporting; can be NULL. */
int port; /* Port number to open. */
CONST char *host; /* Name of host on which to open port. */
- int server; /* 1 if socket should be a server socket,
- * else 0 for a client socket. */
+ int server; /* 1 if socket should be a server socket, else
+ * 0 for a client socket. */
CONST char *myaddr; /* Optional client-side address */
int myport; /* Optional client-side port */
int async; /* If nonzero, connect client socket
* asynchronously. */
{
u_long flag = 1; /* Indicates nonblocking mode. */
- int asyncConnect = 0; /* Will be 1 if async connect is
- * in progress. */
+ int asyncConnect = 0; /* Will be 1 if async connect is in
+ * progress. */
SOCKADDR_IN sockaddr; /* Socket address */
SOCKADDR_IN mysockaddr; /* Socket address for client */
SOCKET sock;
SocketInfo *infoPtr; /* The returned value. */
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ TclThreadDataKeyGet(&dataKey);
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
- return NULL;
+ return NULL;
}
- if (! CreateSocketAddress(&sockaddr, host, port)) {
+ if (!CreateSocketAddress(&sockaddr, host, port)) {
goto error;
}
if ((myaddr != NULL || myport != 0) &&
- ! CreateSocketAddress(&mysockaddr, myaddr, myport)) {
+ !CreateSocketAddress(&mysockaddr, myaddr, myport)) {
goto error;
}
@@ -1121,12 +1108,12 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
}
/*
- * Win-NT has a misfeature that sockets are inherited in child
- * processes by default. Turn off the inherit bit.
+ * Win-NT has a misfeature that sockets are inherited in child processes
+ * by default. Turn off the inherit bit.
*/
- SetHandleInformation( (HANDLE) sock, HANDLE_FLAG_INHERIT, 0 );
-
+ SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0);
+
/*
* Set kernel space buffering
*/
@@ -1135,26 +1122,26 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
if (server) {
/*
- * Bind to the specified port. Note that we must not call setsockopt
+ * Bind to the specified port. Note that we must not call setsockopt
* with SO_REUSEADDR because Microsoft allows addresses to be reused
* even if they are still in use.
- *
- * Bind should not be affected by the socket having already been
- * set into nonblocking mode. If there is trouble, this is one place
- * to look for bugs.
+ *
+ * Bind should not be affected by the socket having already been set
+ * into nonblocking mode. If there is trouble, this is one place to
+ * look for bugs.
*/
-
+
if (winSock.bind(sock, (SOCKADDR *) &sockaddr,
sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
- goto error;
- }
-
- /*
- * Set the maximum number of pending connect requests to the
- * max value allowed on each platform (Win32 and Win32s may be
- * different, and there may be differences between TCP/IP stacks).
- */
-
+ goto error;
+ }
+
+ /*
+ * Set the maximum number of pending connect requests to the max value
+ * allowed on each platform (Win32 and Win32s may be different, and
+ * there may be differences between TCP/IP stacks).
+ */
+
if (winSock.listen(sock, SOMAXCONN) == SOCKET_ERROR) {
goto error;
}
@@ -1173,25 +1160,25 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
infoPtr->watchEvents |= FD_ACCEPT;
} else {
+ /*
+ * Try to bind to a local port, if specified.
+ */
- /*
- * Try to bind to a local port, if specified.
- */
-
- if (myaddr != NULL || myport != 0) {
+ if (myaddr != NULL || myport != 0) {
if (winSock.bind(sock, (SOCKADDR *) &mysockaddr,
sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
goto error;
}
- }
-
+ }
+
/*
- * Set the socket into nonblocking mode if the connect should be
- * done in the background.
+ * Set the socket into nonblocking mode if the connect should be done
+ * in the background.
*/
-
+
if (async) {
- if (winSock.ioctlsocket(sock, (long) FIONBIO, &flag) == SOCKET_ERROR) {
+ if (winSock.ioctlsocket(sock, (long) FIONBIO,
+ &flag) == SOCKET_ERROR) {
goto error;
}
}
@@ -1202,7 +1189,7 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
if (winSock.connect(sock, (SOCKADDR *) &sockaddr,
sizeof(SOCKADDR_IN)) == SOCKET_ERROR) {
- TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
+ TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
if (Tcl_GetErrno() != EWOULDBLOCK) {
goto error;
}
@@ -1212,7 +1199,7 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
*/
asyncConnect = 1;
- }
+ }
/*
* Add this socket to the global list of sockets.
@@ -1221,7 +1208,7 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
infoPtr = NewSocketInfo(sock);
/*
- * Set up the select mask for read/write events. If the connect
+ * Set up the select mask for read/write events. If the connect
* attempt has not completed, include connect events.
*/
@@ -1233,7 +1220,7 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
}
/*
- * Register for interest in events in the select mask. Note that this
+ * Register for interest in events in the select mask. Note that this
* automatically places the socket into non-blocking mode.
*/
@@ -1243,7 +1230,7 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
return infoPtr;
-error:
+ error:
TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
if (interp != NULL) {
Tcl_AppendResult(interp, "couldn't open socket: ",
@@ -1263,8 +1250,8 @@ error:
* This function initializes a sockaddr structure for a host and port.
*
* Results:
- * 1 if the host was valid, 0 if the host could not be converted to
- * an IP address.
+ * 1 if the host was valid, 0 if the host could not be converted to an IP
+ * address.
*
* Side effects:
* Fills in the *sockaddrPtr structure.
@@ -1274,23 +1261,22 @@ error:
static int
CreateSocketAddress(sockaddrPtr, host, port)
- LPSOCKADDR_IN sockaddrPtr; /* Socket address */
- CONST char *host; /* Host. NULL implies INADDR_ANY */
- int port; /* Port number */
+ LPSOCKADDR_IN sockaddrPtr; /* Socket address */
+ CONST char *host; /* Host. NULL implies INADDR_ANY */
+ int port; /* Port number */
{
- struct hostent *hostent; /* Host database entry */
- struct in_addr addr; /* For 64/32 bit madness */
+ struct hostent *hostent; /* Host database entry */
+ struct in_addr addr; /* For 64/32 bit madness */
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
- Tcl_SetErrno(EFAULT);
- return 0;
+ Tcl_SetErrno(EFAULT);
+ return 0;
}
ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN));
@@ -1299,17 +1285,17 @@ CreateSocketAddress(sockaddrPtr, host, port)
if (host == NULL) {
addr.s_addr = INADDR_ANY;
} else {
- addr.s_addr = winSock.inet_addr(host);
- if (addr.s_addr == INADDR_NONE) {
- hostent = winSock.gethostbyname(host);
- if (hostent != NULL) {
- memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length);
- } else {
+ addr.s_addr = winSock.inet_addr(host);
+ if (addr.s_addr == INADDR_NONE) {
+ hostent = winSock.gethostbyname(host);
+ if (hostent != NULL) {
+ memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length);
+ } else {
#ifdef EHOSTUNREACH
- Tcl_SetErrno(EHOSTUNREACH);
+ Tcl_SetErrno(EHOSTUNREACH);
#else
#ifdef ENXIO
- Tcl_SetErrno(ENXIO);
+ Tcl_SetErrno(ENXIO);
#endif
#endif
return 0; /* Error. */
@@ -1318,14 +1304,14 @@ CreateSocketAddress(sockaddrPtr, host, port)
}
/*
- * NOTE: On 64 bit machines the assignment below is rumored to not
- * do the right thing. Please report errors related to this if you
- * observe incorrect behavior on 64 bit machines such as DEC Alphas.
- * Should we modify this code to do an explicit memcpy?
+ * NOTE: On 64 bit machines the assignment below is rumored to not do the
+ * right thing. Please report errors related to this if you observe
+ * incorrect behavior on 64 bit machines such as DEC Alphas. Should we
+ * modify this code to do an explicit memcpy?
*/
sockaddrPtr->sin_addr.s_addr = addr.s_addr;
- return 1; /* Success. */
+ return 1; /* Success. */
}
/*
@@ -1353,15 +1339,15 @@ WaitForSocketEvent(infoPtr, events, errorCodePtr)
{
int result = 1;
int oldMode;
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ TclThreadDataKeyGet(&dataKey);
/*
* Be sure to disable event servicing so we are truly modal.
*/
oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);
-
+
/*
* Reset WSAAsyncSelect so we have a fresh set of events pending.
*/
@@ -1373,7 +1359,6 @@ WaitForSocketEvent(infoPtr, events, errorCodePtr)
(WPARAM) SELECT, (LPARAM) infoPtr);
while (1) {
-
if (infoPtr->lastError) {
*errorCodePtr = infoPtr->lastError;
result = 0;
@@ -1389,9 +1374,10 @@ WaitForSocketEvent(infoPtr, events, errorCodePtr)
/*
* Wait until something happens.
*/
+
WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
}
-
+
(void) Tcl_SetServiceMode(oldMode);
return result;
}
@@ -1404,8 +1390,8 @@ WaitForSocketEvent(infoPtr, events, errorCodePtr)
* Opens a TCP client socket and creates a channel around it.
*
* Results:
- * The channel or NULL if failed. An error message is returned
- * in the interpreter on failure.
+ * The channel or NULL if failed. An error message is returned in the
+ * interpreter on failure.
*
* Side effects:
* Opens a client socket and creates a new channel.
@@ -1415,13 +1401,13 @@ WaitForSocketEvent(infoPtr, events, errorCodePtr)
Tcl_Channel
Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async)
- Tcl_Interp *interp; /* For error reporting; can be NULL. */
- int port; /* Port number to open. */
- CONST char *host; /* Host on which to open port. */
- CONST char *myaddr; /* Client-side address */
- int myport; /* Client-side port */
- int async; /* If nonzero, should connect
- * client socket asynchronously. */
+ Tcl_Interp *interp; /* For error reporting; can be NULL. */
+ int port; /* Port number to open. */
+ CONST char *host; /* Host on which to open port. */
+ CONST char *myaddr; /* Client-side address */
+ int myport; /* Client-side port */
+ int async; /* If nonzero, should connect client socket
+ * asynchronously. */
{
SocketInfo *infoPtr;
char channelName[16 + TCL_INTEGER_SPACE];
@@ -1445,13 +1431,13 @@ Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async)
(ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation",
"auto crlf") == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
- return (Tcl_Channel) NULL;
+ Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
+ return (Tcl_Channel) NULL;
}
if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "")
== TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
- return (Tcl_Channel) NULL;
+ Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
+ return (Tcl_Channel) NULL;
}
return infoPtr->channel;
}
@@ -1519,8 +1505,8 @@ Tcl_MakeTcpClientChannel(sock)
* Opens a TCP server socket and creates a channel around it.
*
* Results:
- * The channel or NULL if failed. An error message is returned
- * in the interpreter on failure.
+ * The channel or NULL if failed. An error message is returned in the
+ * interpreter on failure.
*
* Side effects:
* Opens a server socket and creates a new channel.
@@ -1530,13 +1516,13 @@ Tcl_MakeTcpClientChannel(sock)
Tcl_Channel
Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData)
- Tcl_Interp *interp; /* For error reporting - may be
- * NULL. */
- int port; /* Port number to open. */
- CONST char *host; /* Name of local host. */
- Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections
- * from new clients. */
- ClientData acceptProcData; /* Data for the callback. */
+ Tcl_Interp *interp; /* For error reporting - may be NULL. */
+ int port; /* Port number to open. */
+ CONST char *host; /* Name of local host. */
+ Tcl_TcpAcceptProc *acceptProc;
+ /* Callback for accepting connections from new
+ * clients. */
+ ClientData acceptProcData; /* Data for the callback. */
{
SocketInfo *infoPtr;
char channelName[16 + TCL_INTEGER_SPACE];
@@ -1563,8 +1549,8 @@ Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData)
(ClientData) infoPtr, 0);
if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "")
== TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
- return (Tcl_Channel) NULL;
+ Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
+ return (Tcl_Channel) NULL;
}
return infoPtr->channel;
@@ -1574,9 +1560,9 @@ Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData)
*----------------------------------------------------------------------
*
* TcpAccept --
- * Accept a TCP socket connection. This is called by
- * SocketEventProc and it in turns calls the registered accept
- * procedure.
+ *
+ * Accept a TCP socket connection. This is called by SocketEventProc and
+ * it in turns calls the registered accept function.
*
* Results:
* None.
@@ -1596,8 +1582,8 @@ TcpAccept(infoPtr)
SOCKADDR_IN addr;
int len;
char channelName[16 + TCL_INTEGER_SPACE];
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ TclThreadDataKeyGet(&dataKey);
/*
* Accept the incoming connection request.
@@ -1610,8 +1596,8 @@ TcpAccept(infoPtr)
/*
* Clear the ready mask so we can detect the next connection request.
- * Note that connection requests are level triggered, so if there is
- * a request already pending, a new event will be generated.
+ * Note that connection requests are level triggered, so if there is a
+ * request already pending, a new event will be generated.
*/
if (newSocket == INVALID_SOCKET) {
@@ -1622,7 +1608,7 @@ TcpAccept(infoPtr)
/*
* It is possible that more than one FD_ACCEPT has been sent, so an extra
- * count must be kept. Decrement the count, and reset the readyEvent bit
+ * count must be kept. Decrement the count, and reset the readyEvent bit
* if the count is no longer > 0.
*/
@@ -1633,11 +1619,11 @@ TcpAccept(infoPtr)
}
/*
- * Win-NT has a misfeature that sockets are inherited in child
- * processes by default. Turn off the inherit bit.
+ * Win-NT has a misfeature that sockets are inherited in child processes
+ * by default. Turn off the inherit bit.
*/
- SetHandleInformation( (HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0 );
+ SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0);
/*
* Add this socket to the global list of sockets.
@@ -1668,12 +1654,11 @@ TcpAccept(infoPtr)
}
/*
- * Invoke the accept callback procedure.
+ * Invoke the accept callback function.
*/
if (infoPtr->acceptProc != NULL) {
- (infoPtr->acceptProc) (infoPtr->acceptProcData,
- newInfoPtr->channel,
+ (infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel,
winSock.inet_ntoa(addr.sin_addr),
winSock.ntohs(addr.sin_port));
}
@@ -1684,8 +1669,8 @@ TcpAccept(infoPtr)
*
* TcpInputProc --
*
- * This procedure is called by the generic IO level to read data from
- * a socket based channel.
+ * This function is called by the generic IO level to read data from a
+ * socket based channel.
*
* Results:
* The number of bytes read or -1 on error.
@@ -1698,34 +1683,33 @@ TcpAccept(infoPtr)
static int
TcpInputProc(instanceData, buf, toRead, errorCodePtr)
- ClientData instanceData; /* The socket state. */
- char *buf; /* Where to store data. */
- int toRead; /* Maximum number of bytes to read. */
- int *errorCodePtr; /* Where to store error codes. */
+ ClientData instanceData; /* The socket state. */
+ char *buf; /* Where to store data. */
+ int toRead; /* Maximum number of bytes to read. */
+ int *errorCodePtr; /* Where to store error codes. */
{
SocketInfo *infoPtr = (SocketInfo *) instanceData;
int bytesRead;
DWORD error;
- ThreadSpecificData *tsdPtr =
+ ThreadSpecificData *tsdPtr =
(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
-
+
*errorCodePtr = 0;
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
- *errorCodePtr = EFAULT;
- return -1;
+ *errorCodePtr = EFAULT;
+ return -1;
}
/*
- * First check to see if EOF was already detected, to prevent
- * calling the socket stack after the first time EOF is detected.
+ * First check to see if EOF was already detected, to prevent calling the
+ * socket stack after the first time EOF is detected.
*/
if (infoPtr->flags & SOCKET_EOF) {
@@ -1740,13 +1724,13 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
&& ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) {
return -1;
}
-
+
/*
- * No EOF, and it is connected, so try to read more from the socket.
- * Note that we clear the FD_READ bit because read events are level
- * triggered so a new event will be generated if there is still data
- * available to be read. We have to simulate blocking behavior here
- * since we are always using non-blocking sockets.
+ * No EOF, and it is connected, so try to read more from the socket. Note
+ * that we clear the FD_READ bit because read events are level triggered
+ * so a new event will be generated if there is still data available to be
+ * read. We have to simulate blocking behavior here since we are always
+ * using non-blocking sockets.
*/
while (1) {
@@ -1754,33 +1738,33 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
(WPARAM) UNSELECT, (LPARAM) infoPtr);
bytesRead = winSock.recv(infoPtr->socket, buf, toRead, 0);
infoPtr->readyEvents &= ~(FD_READ);
-
+
/*
* Check for end-of-file condition or successful read.
*/
-
+
if (bytesRead == 0) {
infoPtr->flags |= SOCKET_EOF;
}
if (bytesRead != SOCKET_ERROR) {
break;
}
-
+
/*
- * If an error occurs after the FD_CLOSE has arrived,
- * then ignore the error and report an EOF.
+ * If an error occurs after the FD_CLOSE has arrived, then ignore the
+ * error and report an EOF.
*/
-
+
if (infoPtr->readyEvents & FD_CLOSE) {
infoPtr->flags |= SOCKET_EOF;
bytesRead = 0;
break;
}
-
+
/*
* Check for error condition or underflow in non-blocking case.
*/
-
+
error = winSock.WSAGetLastError();
if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) {
TclWinConvertWSAError(error);
@@ -1790,19 +1774,19 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
}
/*
- * In the blocking case, wait until the file becomes readable
- * or closed and try again.
+ * In the blocking case, wait until the file becomes readable or
+ * closed and try again.
*/
if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) {
bytesRead = -1;
break;
- }
+ }
}
-
+
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) SELECT, (LPARAM) infoPtr);
-
+
return bytesRead;
}
@@ -1811,8 +1795,8 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
*
* TcpOutputProc --
*
- * This procedure is called by the generic IO level to write data
- * to a socket based channel.
+ * This function is called by the generic IO level to write data to a
+ * socket based channel.
*
* Results:
* The number of bytes written or -1 on failure.
@@ -1825,35 +1809,34 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
static int
TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
- ClientData instanceData; /* The socket state. */
- CONST char *buf; /* Where to get data. */
- int toWrite; /* Maximum number of bytes to write. */
- int *errorCodePtr; /* Where to store error codes. */
+ ClientData instanceData; /* The socket state. */
+ CONST char *buf; /* Where to get data. */
+ int toWrite; /* Maximum number of bytes to write. */
+ int *errorCodePtr; /* Where to store error codes. */
{
SocketInfo *infoPtr = (SocketInfo *) instanceData;
int bytesWritten;
DWORD error;
- ThreadSpecificData *tsdPtr =
+ ThreadSpecificData *tsdPtr =
(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
*errorCodePtr = 0;
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
- *errorCodePtr = EFAULT;
- return -1;
+ *errorCodePtr = EFAULT;
+ return -1;
}
/*
* Check to see if the socket is connected before trying to write.
*/
-
+
if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
&& ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) {
return -1;
@@ -1866,22 +1849,22 @@ TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
bytesWritten = winSock.send(infoPtr->socket, buf, toWrite, 0);
if (bytesWritten != SOCKET_ERROR) {
/*
- * Since Windows won't generate a new write event until we hit
- * an overflow condition, we need to force the event loop to
- * poll until the condition changes.
+ * Since Windows won't generate a new write event until we hit an
+ * overflow condition, we need to force the event loop to poll
+ * until the condition changes.
*/
if (infoPtr->watchEvents & FD_WRITE) {
Tcl_Time blockTime = { 0, 0 };
Tcl_SetMaxBlockTime(&blockTime);
- }
+ }
break;
}
-
+
/*
- * Check for error condition or overflow. In the event of overflow, we
+ * Check for error condition or overflow. In the event of overflow, we
* need to clear the FD_WRITE flag so we can detect the next writable
- * event. Note that Windows only sends a new writable event after a
+ * event. Note that Windows only sends a new writable event after a
* send fails with WSAEWOULDBLOCK.
*/
@@ -1892,7 +1875,7 @@ TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
*errorCodePtr = EWOULDBLOCK;
bytesWritten = -1;
break;
- }
+ }
} else {
TclWinConvertWSAError(error);
*errorCodePtr = Tcl_GetErrno();
@@ -1901,8 +1884,8 @@ TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
}
/*
- * In the blocking case, wait until the file becomes writable
- * or closed and try again.
+ * In the blocking case, wait until the file becomes writable or
+ * closed and try again.
*/
if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
@@ -1913,7 +1896,7 @@ TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) SELECT, (LPARAM) infoPtr);
-
+
return bytesWritten;
}
@@ -1947,17 +1930,16 @@ TcpSetOptionProc (
int boolVar, rtn;
*/
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
if (interp) {
Tcl_AppendResult(interp, "winsock is not initialized", NULL);
}
- return TCL_ERROR;
+ return TCL_ERROR;
}
infoPtr = (SocketInfo *) instanceData;
@@ -2009,15 +1991,14 @@ TcpSetOptionProc (
*
* TcpGetOptionProc --
*
- * Computes an option value for a TCP socket based channel, or a
- * list of all options and their values.
+ * Computes an option value for a TCP socket based channel, or a list of
+ * all options and their values.
*
* Note: This code is based on code contributed by John Haxby.
*
* Results:
- * A standard Tcl result. The value of the specified option or a
- * list of all options and their values is returned in the
- * supplied DString.
+ * A standard Tcl result. The value of the specified option or a list of
+ * all options and their values is returned in the supplied DString.
*
* Side effects:
* None.
@@ -2027,14 +2008,13 @@ TcpSetOptionProc (
static int
TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
- ClientData instanceData; /* Socket state. */
- Tcl_Interp *interp; /* For error reporting - can be NULL */
- CONST char *optionName; /* Name of the option to
- * retrieve the value for, or
- * NULL to get all options and
- * their values. */
- Tcl_DString *dsPtr; /* Where to store the computed
- * value; initialized by caller. */
+ ClientData instanceData; /* Socket state. */
+ Tcl_Interp *interp; /* For error reporting - can be NULL */
+ CONST char *optionName; /* Name of the option to retrieve the value
+ * for, or NULL to get all options and their
+ * values. */
+ Tcl_DString *dsPtr; /* Where to store the computed value;
+ * initialized by caller. */
{
SocketInfo *infoPtr;
SOCKADDR_IN sockname;
@@ -2046,23 +2026,22 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
char buf[TCL_INTEGER_SPACE];
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
if (interp) {
Tcl_AppendResult(interp, "winsock is not initialized", NULL);
}
- return TCL_ERROR;
+ return TCL_ERROR;
}
-
+
infoPtr = (SocketInfo *) instanceData;
sock = (int) infoPtr->socket;
if (optionName != (char *) NULL) {
- len = strlen(optionName);
+ len = strlen(optionName);
}
if ((len > 1) && (optionName[1] == 'e') &&
@@ -2070,7 +2049,7 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
int optlen;
DWORD err;
int ret;
-
+
optlen = sizeof(int);
ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR,
(char *)&err, &optlen);
@@ -2084,94 +2063,89 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
return TCL_OK;
}
- if ((len == 0) ||
- ((len > 1) && (optionName[1] == 'p') &&
- (strncmp(optionName, "-peername", len) == 0))) {
- if (winSock.getpeername(sock, (LPSOCKADDR) &peername, &size)
- == 0) {
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-peername");
- Tcl_DStringStartSublist(dsPtr);
- }
- Tcl_DStringAppendElement(dsPtr,
- winSock.inet_ntoa(peername.sin_addr));
+ if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
+ (strncmp(optionName, "-peername", len) == 0))) {
+ if (winSock.getpeername(sock, (LPSOCKADDR) &peername, &size) == 0) {
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-peername");
+ Tcl_DStringStartSublist(dsPtr);
+ }
+ Tcl_DStringAppendElement(dsPtr,
+ winSock.inet_ntoa(peername.sin_addr));
if (peername.sin_addr.s_addr == 0) {
- hostEntPtr = (struct hostent *) NULL;
+ hostEntPtr = (struct hostent *) NULL;
} else {
- hostEntPtr = winSock.gethostbyaddr(
- (char *) &(peername.sin_addr), sizeof(peername.sin_addr),
- AF_INET);
+ hostEntPtr = winSock.gethostbyaddr(
+ (char *) &(peername.sin_addr),
+ sizeof(peername.sin_addr), AF_INET);
+ }
+ if (hostEntPtr != (struct hostent *) NULL) {
+ Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
+ } else {
+ Tcl_DStringAppendElement(dsPtr,
+ winSock.inet_ntoa(peername.sin_addr));
}
- if (hostEntPtr != (struct hostent *) NULL) {
- Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
- } else {
- Tcl_DStringAppendElement(dsPtr,
- winSock.inet_ntoa(peername.sin_addr));
- }
TclFormatInt(buf, winSock.ntohs(peername.sin_port));
- Tcl_DStringAppendElement(dsPtr, buf);
- if (len == 0) {
- Tcl_DStringEndSublist(dsPtr);
- } else {
- return TCL_OK;
- }
- } else {
- /*
- * getpeername failed - but if we were asked for all the options
- * (len==0), don't flag an error at that point because it could
- * be an fconfigure request on a server socket. (which have
- * no peer). {copied from unix/tclUnixChan.c}
- */
- if (len) {
+ Tcl_DStringAppendElement(dsPtr, buf);
+ if (len == 0) {
+ Tcl_DStringEndSublist(dsPtr);
+ } else {
+ return TCL_OK;
+ }
+ } else {
+ /*
+ * getpeername failed - but if we were asked for all the options
+ * (len==0), don't flag an error at that point because it could be
+ * an fconfigure request on a server socket (which have no peer).
+ * {Copied from unix/tclUnixChan.c}
+ */
+
+ if (len) {
TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
- if (interp) {
- Tcl_AppendResult(interp, "can't get peername: ",
- Tcl_PosixError(interp),
- (char *) NULL);
- }
- return TCL_ERROR;
- }
- }
- }
-
- if ((len == 0) ||
- ((len > 1) && (optionName[1] == 's') &&
- (strncmp(optionName, "-sockname", len) == 0))) {
- if (winSock.getsockname(sock, (LPSOCKADDR) &sockname, &size)
- == 0) {
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-sockname");
- Tcl_DStringStartSublist(dsPtr);
- }
- Tcl_DStringAppendElement(dsPtr,
- winSock.inet_ntoa(sockname.sin_addr));
+ if (interp) {
+ Tcl_AppendResult(interp, "can't get peername: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ if ((len == 0) || ((len > 1) && (optionName[1] == 's') &&
+ (strncmp(optionName, "-sockname", len) == 0))) {
+ if (winSock.getsockname(sock, (LPSOCKADDR) &sockname, &size) == 0) {
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-sockname");
+ Tcl_DStringStartSublist(dsPtr);
+ }
+ Tcl_DStringAppendElement(dsPtr,
+ winSock.inet_ntoa(sockname.sin_addr));
if (sockname.sin_addr.s_addr == 0) {
- hostEntPtr = (struct hostent *) NULL;
+ hostEntPtr = (struct hostent *) NULL;
} else {
- hostEntPtr = winSock.gethostbyaddr(
- (char *) &(sockname.sin_addr), sizeof(peername.sin_addr),
- AF_INET);
+ hostEntPtr = winSock.gethostbyaddr(
+ (char *) &(sockname.sin_addr),
+ sizeof(peername.sin_addr), AF_INET);
}
- if (hostEntPtr != (struct hostent *) NULL) {
- Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
- } else {
- Tcl_DStringAppendElement(dsPtr,
- winSock.inet_ntoa(sockname.sin_addr));
- }
- TclFormatInt(buf, winSock.ntohs(sockname.sin_port));
- Tcl_DStringAppendElement(dsPtr, buf);
- if (len == 0) {
- Tcl_DStringEndSublist(dsPtr);
- } else {
- return TCL_OK;
- }
- } else {
+ if (hostEntPtr != (struct hostent *) NULL) {
+ Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
+ } else {
+ Tcl_DStringAppendElement(dsPtr,
+ winSock.inet_ntoa(sockname.sin_addr));
+ }
+ TclFormatInt(buf, winSock.ntohs(sockname.sin_port));
+ Tcl_DStringAppendElement(dsPtr, buf);
+ if (len == 0) {
+ Tcl_DStringEndSublist(dsPtr);
+ } else {
+ return TCL_OK;
+ }
+ } else {
if (interp) {
TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
Tcl_AppendResult(interp, "can't get sockname: ",
- Tcl_PosixError(interp),
- (char *) NULL);
+ Tcl_PosixError(interp), (char *) NULL);
}
return TCL_ERROR;
}
@@ -2181,10 +2155,10 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
if (len == 0 || !strncmp(optionName, "-keepalive", len)) {
int optlen;
BOOL opt = FALSE;
-
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-keepalive");
- }
+
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-keepalive");
+ }
optlen = sizeof(BOOL);
winSock.getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt,
&optlen);
@@ -2201,10 +2175,10 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
if (len == 0 || !strncmp(optionName, "-nagle", len)) {
int optlen;
BOOL opt = FALSE;
-
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-nagle");
- }
+
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-nagle");
+ }
optlen = sizeof(BOOL);
winSock.getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt,
&optlen);
@@ -2220,8 +2194,8 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
*/
if (len > 0) {
- /*return Tcl_BadChannelOption(interp, optionName, "peername sockname keepalive nagle");*/
- return Tcl_BadChannelOption(interp, optionName, "peername sockname");
+ /*return Tcl_BadChannelOption(interp, optionName, "peername sockname keepalive nagle");*/
+ return Tcl_BadChannelOption(interp, optionName, "peername sockname");
}
return TCL_OK;
@@ -2232,45 +2206,45 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
*
* TcpWatchProc --
*
- * Informs the channel driver of the events that the generic
- * channel code wishes to receive on this socket.
+ * Informs the channel driver of the events that the generic channel code
+ * wishes to receive on this socket.
*
* Results:
* None.
*
* Side effects:
- * May cause the notifier to poll if any of the specified
- * conditions are already true.
+ * May cause the notifier to poll if any of the specified conditions are
+ * already true.
*
*----------------------------------------------------------------------
*/
static void
TcpWatchProc(instanceData, mask)
- ClientData instanceData; /* The socket state. */
- int mask; /* Events of interest; an OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
+ ClientData instanceData; /* The socket state. */
+ int mask; /* Events of interest; an OR-ed combination of
+ * TCL_READABLE, TCL_WRITABLE and
+ * TCL_EXCEPTION. */
{
SocketInfo *infoPtr = (SocketInfo *) instanceData;
-
+
/*
- * Update the watch events mask. Only if the socket is not a
- * server socket. Fix for SF Tcl Bug #557878.
+ * Update the watch events mask. Only if the socket is not a server
+ * socket. Fix for SF Tcl Bug #557878.
*/
- if (!infoPtr->acceptProc) {
- infoPtr->watchEvents = 0;
+ if (!infoPtr->acceptProc) {
+ infoPtr->watchEvents = 0;
if (mask & TCL_READABLE) {
infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
}
if (mask & TCL_WRITABLE) {
infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT);
}
-
+
/*
- * If there are any conditions already set, then tell the notifier to poll
- * rather than block.
+ * If there are any conditions already set, then tell the notifier to
+ * poll rather than block.
*/
if (infoPtr->readyEvents & infoPtr->watchEvents) {
@@ -2331,16 +2305,16 @@ SocketThread(LPVOID arg)
MSG msg;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg);
- tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket",
+ tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket",
WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg);
/*
- * Signal the main thread that the window has been created
- * and that the socket thread is ready to go.
+ * Signal the main thread that the window has been created and that the
+ * socket thread is ready to go.
*/
-
+
SetEvent(tsdPtr->readyEvent);
-
+
if (tsdPtr->hwnd == NULL) {
return 1;
}
@@ -2362,16 +2336,15 @@ SocketThread(LPVOID arg)
*
* SocketProc --
*
- * This function is called when WSAAsyncSelect has been used
- * to register interest in a socket event, and the event has
- * occurred.
+ * This function is called when WSAAsyncSelect has been used to register
+ * interest in a socket event, and the event has occurred.
*
* Results:
* 0 on success.
*
* Side effects:
- * The flags for the given socket are updated to reflect the
- * event that occured.
+ * The flags for the given socket are updated to reflect the event that
+ * occured.
*
*----------------------------------------------------------------------
*/
@@ -2394,120 +2367,117 @@ SocketProc(hwnd, message, wParam, lParam)
#endif
switch (message) {
+ default:
+ return DefWindowProc(hwnd, message, wParam, lParam);
+ break;
- default:
- return DefWindowProc(hwnd, message, wParam, lParam);
- break;
-
- case WM_CREATE:
- /*
- * store the initial tsdPtr, it's from a different thread, so it's
- * not directly accessible, but needed.
- */
+ case WM_CREATE:
+ /*
+ * store the initial tsdPtr, it's from a different thread, so it's not
+ * directly accessible, but needed.
+ */
#ifdef _WIN64
- SetWindowLongPtr(hwnd, GWLP_USERDATA,
- (LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams);
+ SetWindowLongPtr(hwnd, GWLP_USERDATA,
+ (LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#else
- SetWindowLong(hwnd, GWL_USERDATA,
- (LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams);
+ SetWindowLong(hwnd, GWL_USERDATA,
+ (LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#endif
- break;
+ break;
- case WM_DESTROY:
- PostQuitMessage(0);
- break;
+ case WM_DESTROY:
+ PostQuitMessage(0);
+ break;
- case SOCKET_MESSAGE:
- event = WSAGETSELECTEVENT(lParam);
- error = WSAGETSELECTERROR(lParam);
- socket = (SOCKET) wParam;
+ case SOCKET_MESSAGE:
+ event = WSAGETSELECTEVENT(lParam);
+ error = WSAGETSELECTERROR(lParam);
+ socket = (SOCKET) wParam;
- /*
- * Find the specified socket on the socket list and update its
- * eventState flag.
- */
+ /*
+ * Find the specified socket on the socket list and update its
+ * eventState flag.
+ */
+
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+ for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->socket == socket) {
+ /*
+ * Update the socket state.
+ */
+
+ /*
+ * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event
+ * happens, then clear the FD_ACCEPT count. Otherwise,
+ * increment the count if the current event is an FD_ACCEPT.
+ */
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (infoPtr->socket == socket) {
+ if (event & FD_CLOSE) {
+ infoPtr->acceptEventCount = 0;
+ infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
+ } else if (event & FD_ACCEPT) {
+ infoPtr->acceptEventCount++;
+ }
+
+ if (event & FD_CONNECT) {
/*
- * Update the socket state.
+ * The socket is now connected, clear the async connect
+ * flag.
*/
+ infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
+
/*
- * A count of FD_ACCEPTS is stored, so if an FD_CLOSE
- * event happens, then clear the FD_ACCEPT count.
- * Otherwise, increment the count if the current
- * event is an FD_ACCEPT.
+ * Remember any error that occurred so we can report
+ * connection failures.
*/
- if (event & FD_CLOSE) {
- infoPtr->acceptEventCount = 0;
- infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
- } else if (event & FD_ACCEPT) {
- infoPtr->acceptEventCount++;
+ if (error != ERROR_SUCCESS) {
+ TclWinConvertWSAError((DWORD) error);
+ infoPtr->lastError = Tcl_GetErrno();
}
+ }
- if (event & FD_CONNECT) {
- /*
- * The socket is now connected,
- * clear the async connect flag.
- */
-
- infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
-
- /*
- * Remember any error that occurred so we can report
- * connection failures.
- */
-
- if (error != ERROR_SUCCESS) {
- TclWinConvertWSAError((DWORD) error);
- infoPtr->lastError = Tcl_GetErrno();
- }
-
- }
- if (infoPtr->flags & SOCKET_ASYNC_CONNECT) {
- infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
- if (error != ERROR_SUCCESS) {
- TclWinConvertWSAError((DWORD) error);
- infoPtr->lastError = Tcl_GetErrno();
- }
- infoPtr->readyEvents |= FD_WRITE;
+ if (infoPtr->flags & SOCKET_ASYNC_CONNECT) {
+ infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
+ if (error != ERROR_SUCCESS) {
+ TclWinConvertWSAError((DWORD) error);
+ infoPtr->lastError = Tcl_GetErrno();
}
- infoPtr->readyEvents |= event;
-
- /*
- * Wake up the Main Thread.
- */
- SetEvent(tsdPtr->readyEvent);
- Tcl_ThreadAlert(tsdPtr->threadId);
- break;
+ infoPtr->readyEvents |= FD_WRITE;
}
- }
- SetEvent(tsdPtr->socketListLock);
- break;
-
- case SOCKET_SELECT:
- infoPtr = (SocketInfo *) lParam;
- if (wParam == SELECT) {
+ infoPtr->readyEvents |= event;
- winSock.WSAAsyncSelect(infoPtr->socket, hwnd,
- SOCKET_MESSAGE, infoPtr->selectEvents);
- } else {
/*
- * Clear the selection mask
+ * Wake up the Main Thread.
*/
-
- winSock.WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0);
+ SetEvent(tsdPtr->readyEvent);
+ Tcl_ThreadAlert(tsdPtr->threadId);
+ break;
}
- break;
+ }
+ SetEvent(tsdPtr->socketListLock);
+ break;
- case SOCKET_TERMINATE:
- DestroyWindow(hwnd);
- break;
+ case SOCKET_SELECT:
+ infoPtr = (SocketInfo *) lParam;
+ if (wParam == SELECT) {
+ winSock.WSAAsyncSelect(infoPtr->socket, hwnd,
+ SOCKET_MESSAGE, infoPtr->selectEvents);
+ } else {
+ /*
+ * Clear the selection mask
+ */
+
+ winSock.WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0);
+ }
+ break;
+
+ case SOCKET_TERMINATE:
+ DestroyWindow(hwnd);
+ break;
}
return 0;
@@ -2521,8 +2491,8 @@ SocketProc(hwnd, message, wParam, lParam)
* Returns the name of the local host.
*
* Results:
- * A string containing the network name for this machine.
- * The caller must not modify or free this string.
+ * A string containing the network name for this machine. The caller must
+ * not modify or free this string.
*
* Side effects:
* Caches the name to return for future calls.
@@ -2541,11 +2511,11 @@ Tcl_GetHostName()
*
* InitializeHostName --
*
- * This routine sets the process global value of the name of
- * the local host on which the process is running.
+ * This routine sets the process global value of the name of the local
+ * host on which the process is running.
*
* Results:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -2564,21 +2534,25 @@ InitializeHostName(valuePtr, lengthPtr, encodingPtr)
/*
* Convert string from native to UTF then change to lowercase.
*/
+
Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds));
+
} else if (TclpHasSockets(NULL) == TCL_OK) {
/*
- * Buffer length of 255 copied slavishly from previous version
- * of this routine. Presumably there's a more "correct" macro
- * value for a properly sized buffer for a gethostname() call.
- * Maintainers are welcome to supply it.
+ * Buffer length of 255 copied slavishly from previous version of this
+ * routine. Presumably there's a more "correct" macro value for a
+ * properly sized buffer for a gethostname() call. Maintainers are
+ * welcome to supply it.
*/
+
Tcl_DStringInit(&ds);
Tcl_DStringSetLength(&ds, 255);
- if (winSock.gethostname(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))
- == 0) {
+ if (winSock.gethostname(Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds)) == 0) {
Tcl_DStringSetLength(&ds, 0);
}
}
+
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
*valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
@@ -2592,10 +2566,10 @@ InitializeHostName(valuePtr, lengthPtr, encodingPtr)
*
* TclWinGetSockOpt, et al. --
*
- * These functions are wrappers that let us bind the WinSock
- * API dynamically so we can run on systems that don't have
- * the wsock32.dll. We need wrappers for these interfaces
- * because they are called from the generic Tcl code.
+ * These functions are wrappers that let us bind the WinSock API
+ * dynamically so we can run on systems that don't have the wsock32.dll.
+ * We need wrappers for these interfaces because they are called from the
+ * generic Tcl code.
*
* Results:
* As defined for each function.
@@ -2611,16 +2585,15 @@ TclWinGetSockOpt(SOCKET s, int level, int optname, char * optval,
int FAR *optlen)
{
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
- return SOCKET_ERROR;
+ return SOCKET_ERROR;
}
-
+
return winSock.getsockopt(s, level, optname, optval, optlen);
}
@@ -2629,13 +2602,13 @@ TclWinSetSockOpt(SOCKET s, int level, int optname, const char * optval,
int optlen)
{
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
+
if (!SocketsEnabled()) {
- return SOCKET_ERROR;
+ return SOCKET_ERROR;
}
return winSock.setsockopt(s, level, optname, optval, optlen);
@@ -2645,14 +2618,13 @@ u_short
TclWinNToHS(u_short netshort)
{
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
- return (u_short) -1;
+ return (u_short) -1;
}
return winSock.ntohs(netshort);
@@ -2662,13 +2634,13 @@ struct servent *
TclWinGetServByName(const char * name, const char * proto)
{
/*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
+ * Check that WinSock is initialized; do not call it if not, to prevent
+ * system crashes. This can happen at exit time if the exit handler for
+ * WinSock ran before other exit handlers that want to use sockets.
*/
+
if (!SocketsEnabled()) {
- return (struct servent *) NULL;
+ return (struct servent *) NULL;
}
return winSock.getservbyname(name, proto);
@@ -2697,15 +2669,15 @@ TcpThreadActionProc (instanceData, action)
{
ThreadSpecificData *tsdPtr;
SocketInfo *infoPtr = (SocketInfo *) instanceData;
- int notifyCmd;
+ int notifyCmd;
if (action == TCL_CHANNEL_THREAD_INSERT) {
- /*
- * Ensure that socket subsystem is initialized in this thread, or
- * else sockets will not work.
+ /*
+ * Ensure that socket subsystem is initialized in this thread, or else
+ * sockets will not work.
*/
- Tcl_MutexLock(&socketMutex);
+ Tcl_MutexLock(&socketMutex);
InitSockets();
Tcl_MutexUnlock(&socketMutex);
@@ -2718,17 +2690,21 @@ TcpThreadActionProc (instanceData, action)
notifyCmd = SELECT;
} else {
- SocketInfo **nextPtrPtr;
+ SocketInfo **nextPtrPtr;
int removed = 0;
- tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * TIP #218, Bugfix: All access to socketList has to be protected by
+ * the lock.
+ */
- /* TIP #218, Bugfix: All access to socketList has to be protected by the lock */
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == infoPtr) {
- (*nextPtrPtr) = infoPtr->nextPtr;
+ (*nextPtrPtr) = infoPtr->nextPtr;
removed = 1;
break;
}
@@ -2736,9 +2712,9 @@ TcpThreadActionProc (instanceData, action)
SetEvent(tsdPtr->socketListLock);
/*
- * This could happen if the channel was created in one thread
- * and then moved to another without updating the thread
- * local data in each thread.
+ * This could happen if the channel was created in one thread and then
+ * moved to another without updating the thread local data in each
+ * thread.
*/
if (!removed) {
@@ -2749,9 +2725,18 @@ TcpThreadActionProc (instanceData, action)
}
/*
- * Ensure that, or stop, notifications for the socket occur in this thread.
+ * Ensure that, or stop, notifications for the socket occur in this
+ * thread.
*/
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) notifyCmd, (LPARAM) infoPtr);
+ (WPARAM) notifyCmd, (LPARAM) infoPtr);
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
index cb9c958..11d3870 100644
--- a/win/tclWinThrd.c
+++ b/win/tclWinThrd.c
@@ -1,4 +1,4 @@
-/*
+/*
* tclWinThread.c --
*
* This file implements the Windows-specific thread operations.
@@ -6,10 +6,10 @@
* Copyright (c) 1998 by 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: tclWinThrd.c,v 1.38 2005/05/30 07:56:12 vasiljevic Exp $
+ * RCS: @(#) $Id: tclWinThrd.c,v 1.39 2005/07/24 22:56:50 dkf Exp $
*/
#include "tclWinInt.h"
@@ -19,8 +19,8 @@
#include <sys/stat.h>
/*
- * This is the master lock used to serialize access to other
- * serialization data structures.
+ * This is the master lock used to serialize access to other serialization
+ * data structures.
*/
static CRITICAL_SECTION masterLock;
@@ -37,8 +37,8 @@ static int init = 0;
static CRITICAL_SECTION initLock;
/*
- * allocLock is used by Tcl's version of malloc for synchronization.
- * For obvious reasons, cannot use any dyamically allocated storage.
+ * allocLock is used by Tcl's version of malloc for synchronization. For
+ * obvious reasons, cannot use any dyamically allocated storage.
*/
#ifdef TCL_THREADS
@@ -51,24 +51,23 @@ static int allocOnce = 0;
/*
* The joinLock serializes Create- and ExitThread. This is necessary to
- * prevent a race where a new joinable thread exits before the creating
- * thread had the time to create the necessary data structures in the
- * emulation layer.
+ * prevent a race where a new joinable thread exits before the creating thread
+ * had the time to create the necessary data structures in the emulation
+ * layer.
*/
static CRITICAL_SECTION joinLock;
/*
- * Condition variables are implemented with a combination of a
- * per-thread Windows Event and a per-condition waiting queue.
- * The idea is that each thread has its own Event that it waits
- * on when it is doing a ConditionWait; it uses the same event for
- * all condition variables because it only waits on one at a time.
- * Each condition variable has a queue of waiting threads, and a
- * mutex used to serialize access to this queue.
- *
- * Special thanks to David Nichols and
- * Jim Davidson for advice on the Condition Variable implementation.
+ * Condition variables are implemented with a combination of a per-thread
+ * Windows Event and a per-condition waiting queue. The idea is that each
+ * thread has its own Event that it waits on when it is doing a ConditionWait;
+ * it uses the same event for all condition variables because it only waits on
+ * one at a time. Each condition variable has a queue of waiting threads, and
+ * a mutex used to serialize access to this queue.
+ *
+ * Special thanks to David Nichols and Jim Davidson for advice on the
+ * Condition Variable implementation.
*/
/*
@@ -89,12 +88,12 @@ static Tcl_ThreadDataKey dataKey;
/*
* State bits for the thread.
- * WIN_THREAD_UNINIT Uninitialized. Must be zero because
- * of the way ThreadSpecificData is created.
+ * WIN_THREAD_UNINIT Uninitialized. Must be zero because of the way
+ * ThreadSpecificData is created.
* WIN_THREAD_RUNNING Running, not waiting.
* WIN_THREAD_BLOCKED Waiting, or trying to wait.
* WIN_THREAD_DEAD Dying - no per-thread event anymore.
- */
+ */
#define WIN_THREAD_UNINIT 0x0
#define WIN_THREAD_RUNNING 0x1
@@ -102,12 +101,13 @@ static Tcl_ThreadDataKey dataKey;
#define WIN_THREAD_DEAD 0x4
/*
- * The per condition queue pointers and the
- * Mutex used to serialize access to the queue.
+ * The per condition queue pointers and the Mutex used to serialize access to
+ * the queue.
*/
typedef struct WinCondition {
- CRITICAL_SECTION condLock; /* Lock to serialize queuing on the condition */
+ CRITICAL_SECTION condLock; /* Lock to serialize queuing on the
+ * condition. */
struct ThreadSpecificData *firstPtr; /* Queue pointers */
struct ThreadSpecificData *lastPtr;
} WinCondition;
@@ -115,15 +115,16 @@ typedef struct WinCondition {
/*
* Additions by AOL for specialized thread memory allocator.
*/
+
#ifdef USE_THREAD_ALLOC
static int once;
static DWORD tlsKey;
typedef struct allocMutex {
- Tcl_Mutex tlock;
+ Tcl_Mutex tlock;
CRITICAL_SECTION wlock;
} allocMutex;
-#endif
+#endif /* USE_THREAD_ALLOC */
/*
*----------------------------------------------------------------------
@@ -133,8 +134,8 @@ typedef struct allocMutex {
* This procedure creates a new thread.
*
* Results:
- * TCL_OK if the thread could be created. The thread ID is
- * returned in a parameter.
+ * TCL_OK if the thread could be created. The thread ID is returned in a
+ * parameter.
*
* Side effects:
* A new thread is created.
@@ -144,12 +145,12 @@ typedef struct allocMutex {
int
TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
- Tcl_ThreadId *idPtr; /* Return, the ID of the thread */
- Tcl_ThreadCreateProc proc; /* Main() function of the thread */
- ClientData clientData; /* The one argument to Main() */
- int stackSize; /* Size of stack for the new thread */
- int flags; /* Flags controlling behaviour of
- * the new thread */
+ Tcl_ThreadId *idPtr; /* Return, the ID of the thread. */
+ Tcl_ThreadCreateProc proc; /* Main() function of the thread. */
+ ClientData clientData; /* The one argument to Main(). */
+ int stackSize; /* Size of stack for the new thread. */
+ int flags; /* Flags controlling behaviour of the
+ * new thread. */
{
HANDLE tHandle;
@@ -157,7 +158,7 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, proc,
- clientData, 0, (unsigned *)idPtr);
+ clientData, 0, (unsigned *)idPtr);
#else
tHandle = CreateThread(NULL, (DWORD) stackSize,
(LPTHREAD_START_ROUTINE) proc, (LPVOID) clientData,
@@ -165,11 +166,11 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
#endif
if (tHandle == NULL) {
- LeaveCriticalSection(&joinLock);
+ LeaveCriticalSection(&joinLock);
return TCL_ERROR;
} else {
- if (flags & TCL_THREAD_JOINABLE) {
- TclRememberJoinableThread (*idPtr);
+ if (flags & TCL_THREAD_JOINABLE) {
+ TclRememberJoinableThread(*idPtr);
}
/*
@@ -202,12 +203,11 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
int
Tcl_JoinThread(threadId, result)
- Tcl_ThreadId threadId; /* Id of the thread to wait upon */
- int* result; /* Reference to the storage the result
- * of the thread we wait upon will be
- * written into. */
+ Tcl_ThreadId threadId; /* Id of the thread to wait upon */
+ int *result; /* Reference to the storage the result of the
+ * thread we wait upon will be written into. */
{
- return TclJoinThread (threadId, result);
+ return TclJoinThread(threadId, result);
}
/*
@@ -231,7 +231,7 @@ TclpThreadExit(status)
int status;
{
EnterCriticalSection(&joinLock);
- TclSignalExitThread (Tcl_GetCurrentThread (), status);
+ TclSignalExitThread(Tcl_GetCurrentThread(), status);
LeaveCriticalSection(&joinLock);
#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
@@ -260,7 +260,7 @@ TclpThreadExit(status)
Tcl_ThreadId
Tcl_GetCurrentThread()
{
- return (Tcl_ThreadId)GetCurrentThreadId();
+ return (Tcl_ThreadId) GetCurrentThreadId();
}
/*
@@ -269,9 +269,9 @@ Tcl_GetCurrentThread()
* TclpInitLock
*
* This procedure is used to grab a lock that serializes initialization
- * and finalization of Tcl. On some platforms this may also initialize
- * the mutex used to serialize creation of more mutexes and thread
- * local storage keys.
+ * and finalization of Tcl. On some platforms this may also initialize
+ * the mutex used to serialize creation of more mutexes and thread local
+ * storage keys.
*
* Results:
* None.
@@ -287,11 +287,12 @@ TclpInitLock()
{
if (!init) {
/*
- * There is a fundamental race here that is solved by creating
- * the first Tcl interpreter in a single threaded environment.
- * Once the interpreter has been created, it is safe to create
- * more threads that create interpreters in parallel.
+ * There is a fundamental race here that is solved by creating the
+ * first Tcl interpreter in a single threaded environment. Once the
+ * interpreter has been created, it is safe to create more threads
+ * that create interpreters in parallel.
*/
+
init = 1;
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
@@ -305,8 +306,8 @@ TclpInitLock()
*
* TclpInitUnlock
*
- * This procedure is used to release a lock that serializes initialization
- * and finalization of Tcl.
+ * This procedure is used to release a lock that serializes
+ * initialization and finalization of Tcl.
*
* Results:
* None.
@@ -328,11 +329,11 @@ TclpInitUnlock()
*
* TclpMasterLock
*
- * This procedure is used to grab a lock that serializes creation
- * of mutexes, condition variables, and thread local storage keys.
+ * This procedure is used to grab a lock that serializes creation of
+ * mutexes, condition variables, and thread local storage keys.
*
- * This lock must be different than the initLock because the
- * initLock is held during creation of syncronization objects.
+ * This lock must be different than the initLock because the initLock is
+ * held during creation of syncronization objects.
*
* Results:
* None.
@@ -348,11 +349,12 @@ TclpMasterLock()
{
if (!init) {
/*
- * There is a fundamental race here that is solved by creating
- * the first Tcl interpreter in a single threaded environment.
- * Once the interpreter has been created, it is safe to create
- * more threads that create interpreters in parallel.
+ * There is a fundamental race here that is solved by creating the
+ * first Tcl interpreter in a single threaded environment. Once the
+ * interpreter has been created, it is safe to create more threads
+ * that create interpreters in parallel.
*/
+
init = 1;
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
@@ -366,8 +368,8 @@ TclpMasterLock()
*
* TclpMasterUnlock
*
- * This procedure is used to release a lock that serializes creation
- * and deletion of synchronization objects.
+ * This procedure is used to release a lock that serializes creation and
+ * deletion of synchronization objects.
*
* Results:
* None.
@@ -389,13 +391,13 @@ TclpMasterUnlock()
*
* Tcl_GetAllocMutex
*
- * This procedure returns a pointer to a statically initialized
- * mutex for use by the memory allocator. The alloctor must
- * use this lock, because all other locks are allocated...
+ * This procedure returns a pointer to a statically initialized mutex for
+ * use by the memory allocator. The alloctor must use this lock, because
+ * all other locks are allocated...
*
* Results:
- * A pointer to a mutex that is suitable for passing to
- * Tcl_MutexLock and Tcl_MutexUnlock.
+ * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
+ * Tcl_MutexUnlock.
*
* Side effects:
* None.
@@ -422,35 +424,45 @@ Tcl_GetAllocMutex()
*
* TclpFinalizeLock
*
- * 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.
*
* Side effects:
- * Destroys everything private. TclpInitLock must be held
- * entering this function.
+ * Destroys everything private. TclpInitLock must be held entering this
+ * function.
*
*----------------------------------------------------------------------
*/
void
-TclFinalizeLock ()
+TclFinalizeLock()
{
MASTER_LOCK;
DeleteCriticalSection(&joinLock);
- /* Destroy the critical section that we are holding! */
+
+ /*
+ * Destroy the critical section that we are holding!
+ */
+
DeleteCriticalSection(&masterLock);
init = 0;
+
#ifdef TCL_THREADS
if (allocOnce) {
DeleteCriticalSection(&allocLock);
allocOnce = 0;
}
#endif
+
LeaveCriticalSection(&initLock);
- /* Destroy the critical section that we were holding. */
+
+ /*
+ * Destroy the critical section that we were holding.
+ */
+
DeleteCriticalSection(&initLock);
}
@@ -458,23 +470,20 @@ TclFinalizeLock ()
/* locally used prototype */
static void FinalizeConditionEvent(ClientData data);
-
/*
*----------------------------------------------------------------------
*
* Tcl_MutexLock --
*
- * This procedure is invoked to lock a mutex. This is a self
- * initializing mutex that is automatically finalized during
- * Tcl_Finalize.
+ * This procedure is invoked to lock a mutex. This is a self initializing
+ * mutex that is automatically finalized during Tcl_Finalize.
*
* Results:
* None.
*
* Side effects:
- * May block the current thread. The mutex is aquired when
- * this returns.
+ * May block the current thread. The mutex is aquired when this returns.
*
*----------------------------------------------------------------------
*/
@@ -487,12 +496,12 @@ Tcl_MutexLock(mutexPtr)
if (*mutexPtr == NULL) {
MASTER_LOCK;
- /*
+ /*
* Double inside master lock check to avoid a race.
*/
if (*mutexPtr == NULL) {
- csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION));
+ csPtr = (CRITICAL_SECTION *) ckalloc(sizeof(CRITICAL_SECTION));
InitializeCriticalSection(csPtr);
*mutexPtr = (Tcl_Mutex)csPtr;
TclRememberMutex(mutexPtr);
@@ -532,8 +541,8 @@ Tcl_MutexUnlock(mutexPtr)
*
* TclpFinalizeMutex --
*
- * This procedure is invoked to clean up one mutex. This is only
- * safe to call at the end of time.
+ * This procedure is invoked to clean up one mutex. This is only safe to
+ * call at the end of time.
*
* Results:
* None.
@@ -561,30 +570,29 @@ TclpFinalizeMutex(mutexPtr)
*
* TclpThreadDataKeyInit --
*
- * This procedure initializes a thread specific data block key.
- * Each thread has table of pointers to thread specific data.
- * all threads agree on which table entry is used by each module.
- * this is remembered in a "data key", that is just an index into
- * this table. To allow self initialization, the interface
- * passes a pointer to this key and the first thread to use
- * the key fills in the pointer to the key. The key should be
- * a process-wide static.
+ * This procedure initializes a thread specific data block key. Each
+ * thread has table of pointers to thread specific data. All threads
+ * agree on which table entry is used by each module. This is remembered
+ * in a "data key", that is just an index into this table. To allow self
+ * initialization, the interface passes a pointer to this key and the
+ * first thread to use the key fills in the pointer to the key. The key
+ * should be a process-wide static.
*
* Results:
* None.
*
* Side effects:
- * Will allocate memory the first time this process calls for
- * this key. In this case it modifies its argument
- * to hold the pointer to information about the key.
+ * Will allocate memory the first time this process calls for this key.
+ * In this case it modifies its argument to hold the pointer to
+ * information about the key.
*
*----------------------------------------------------------------------
*/
void
TclpThreadDataKeyInit(keyPtr)
- Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
- * really (DWORD **) */
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really
+ * (DWORD **) */
{
DWORD *indexPtr;
DWORD newKey;
@@ -593,11 +601,12 @@ TclpThreadDataKeyInit(keyPtr)
if (*keyPtr == NULL) {
indexPtr = (DWORD *)ckalloc(sizeof(DWORD));
newKey = TlsAlloc();
- if (newKey != TLS_OUT_OF_INDEXES) {
- *indexPtr = newKey;
- } else {
- Tcl_Panic("TlsAlloc failed from TclpThreadDataKeyInit!"); /* this should be a fatal error */
- }
+ if (newKey == TLS_OUT_OF_INDEXES) {
+ Tcl_Panic("TlsAlloc failed from TclpThreadDataKeyInit!");
+ /* This should have been a fatal error. */
+ }
+
+ *indexPtr = newKey;
*keyPtr = (Tcl_ThreadDataKey)indexPtr;
TclRememberDataKey(keyPtr);
}
@@ -612,8 +621,8 @@ TclpThreadDataKeyInit(keyPtr)
* This procedure returns a pointer to a block of thread local storage.
*
* Results:
- * A thread-specific pointer to the data structure, or NULL
- * if the memory has not been assigned to this key for this thread.
+ * A thread-specific pointer to the data structure, or NULL if the memory
+ * has not been assigned to this key for this thread.
*
* Side effects:
* None.
@@ -623,20 +632,20 @@ TclpThreadDataKeyInit(keyPtr)
VOID *
TclpThreadDataKeyGet(keyPtr)
- Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
- * really (DWORD **) */
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really
+ * (DWORD **) */
{
DWORD *indexPtr = *(DWORD **)keyPtr;
LPVOID result;
+
if (indexPtr == NULL) {
return NULL;
- } else {
- result = TlsGetValue(*indexPtr);
- if ((result == NULL) && (GetLastError() != NO_ERROR)) {
- Tcl_Panic("TlsGetValue failed from TclpThreadDataKeyGet!");
- }
- return result;
}
+ result = TlsGetValue(*indexPtr);
+ if ((result == NULL) && (GetLastError() != NO_ERROR)) {
+ Tcl_Panic("TlsGetValue failed from TclpThreadDataKeyGet!");
+ }
+ return result;
}
/*
@@ -650,23 +659,24 @@ TclpThreadDataKeyGet(keyPtr)
* None.
*
* Side effects:
- * Sets up the thread so future calls to TclpThreadDataKeyGet with
- * this key will return the data pointer.
+ * Sets up the thread so future calls to TclpThreadDataKeyGet with this
+ * key will return the data pointer.
*
*----------------------------------------------------------------------
*/
void
TclpThreadDataKeySet(keyPtr, data)
- Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
- * really (pthread_key_t **) */
- VOID *data; /* Thread local storage */
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really
+ * (pthread_key_t **) */
+ VOID *data; /* Thread local storage. */
{
DWORD *indexPtr = *(DWORD **)keyPtr;
BOOL success;
+
success = TlsSetValue(*indexPtr, (void *)data);
if (!success) {
- Tcl_Panic("TlsSetValue failed from TclpThreadDataKeySet!");
+ Tcl_Panic("TlsSetValue failed from TclpThreadDataKeySet!");
}
}
@@ -675,8 +685,8 @@ TclpThreadDataKeySet(keyPtr, data)
*
* TclpFinalizeThreadData --
*
- * This procedure cleans up the thread-local storage. This is
- * called once for each thread.
+ * This procedure cleans up the thread-local storage. This is called once
+ * for each thread.
*
* Results:
* None.
@@ -697,23 +707,23 @@ TclpFinalizeThreadData(keyPtr)
if (*keyPtr != NULL) {
indexPtr = *(DWORD **)keyPtr;
- result = (VOID *)TlsGetValue(*indexPtr);
+ result = (VOID *) TlsGetValue(*indexPtr);
+
if (result != NULL) {
#if defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG)
- if (indexPtr == &tlsKey) {
- TclpFreeAllocCache(result);
- return;
- }
-#endif
+ if (indexPtr == &tlsKey) {
+ TclpFreeAllocCache(result);
+ return;
+ }
+#endif /* USE_THREAD_ALLOC && !TCL_MEM_DEBUG */
+
ckfree((char *)result);
success = TlsSetValue(*indexPtr, (void *)NULL);
- if (!success) {
- Tcl_Panic("TlsSetValue failed from TclpFinalizeThreadData!");
- }
- } else {
- if (GetLastError() != NO_ERROR) {
- Tcl_Panic("TlsGetValue failed from TclpFinalizeThreadData!");
- }
+ if (!success) {
+ Tcl_Panic("TlsSetValue failed from TclpFinalizeThreadData!");
+ }
+ } else if (GetLastError() != NO_ERROR) {
+ Tcl_Panic("TlsGetValue failed from TclpFinalizeThreadData!");
}
}
}
@@ -723,9 +733,9 @@ TclpFinalizeThreadData(keyPtr)
*
* TclpFinalizeThreadDataKey --
*
- * This procedure is invoked to clean up one key. This is a
- * process-wide storage identifier. The thread finalization code
- * cleans up the thread local storage itself.
+ * This procedure is invoked to clean up one key. This is a process-wide
+ * storage identifier. The thread finalization code cleans up the thread
+ * local storage itself.
*
* This assumes the master lock is held.
*
@@ -747,9 +757,9 @@ TclpFinalizeThreadDataKey(keyPtr)
if (*keyPtr != NULL) {
indexPtr = *(DWORD **)keyPtr;
success = TlsFree(*indexPtr);
- if (!success) {
- Tcl_Panic("TlsFree failed from TclpFinalizeThreadDataKey!");
- }
+ if (!success) {
+ Tcl_Panic("TlsFree failed from TclpFinalizeThreadDataKey!");
+ }
ckfree((char *)indexPtr);
*keyPtr = NULL;
}
@@ -760,9 +770,9 @@ TclpFinalizeThreadDataKey(keyPtr)
*
* Tcl_ConditionWait --
*
- * This procedure is invoked to wait on a condition variable.
- * The mutex is atomically released as part of the wait, and
- * automatically grabbed when the condition is signaled.
+ * This procedure is invoked to wait on a condition variable. The mutex
+ * is atomically released as part of the wait, and automatically grabbed
+ * when the condition is signaled.
*
* The mutex must be held when this procedure is called.
*
@@ -770,9 +780,9 @@ TclpFinalizeThreadDataKey(keyPtr)
* None.
*
* Side effects:
- * May block the current thread. The mutex is aquired when
- * this returns. Will allocate memory for a HANDLE
- * and initialize this the first time this Tcl_Condition is used.
+ * May block the current thread. The mutex is aquired when this returns.
+ * Will allocate memory for a HANDLE and initialize this the first time
+ * this Tcl_Condition is used.
*
*----------------------------------------------------------------------
*/
@@ -799,21 +809,20 @@ Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
}
/*
- * Self initialize the two parts of the condition.
- * The per-condition and per-thread parts need to be
- * handled independently.
+ * Self initialize the two parts of the condition. The per-condition and
+ * per-thread parts need to be handled independently.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
MASTER_LOCK;
- /*
+ /*
* Create the per-thread event and queue pointers.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */,
- FALSE /* non signaled */, NULL);
+ FALSE /* non signaled */, NULL);
tsdPtr->nextPtr = NULL;
tsdPtr->prevPtr = NULL;
tsdPtr->flags = WIN_THREAD_RUNNING;
@@ -823,13 +832,12 @@ Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
if (doExit) {
/*
- * Create a per-thread exit handler to clean up the condEvent.
- * We must be careful to do this outside the Master Lock
- * because Tcl_CreateThreadExitHandler uses its own
- * ThreadSpecificData, and initializing that may drop
- * back into the Master Lock.
+ * Create a per-thread exit handler to clean up the condEvent. We
+ * must be careful to do this outside the Master Lock because
+ * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData,
+ * and initializing that may drop back into the Master Lock.
*/
-
+
Tcl_CreateThreadExitHandler(FinalizeConditionEvent,
(ClientData) tsdPtr);
}
@@ -861,8 +869,8 @@ Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
}
/*
- * Queue the thread on the condition, using
- * the per-condition lock for serialization.
+ * Queue the thread on the condition, using the per-condition lock for
+ * serialization.
*/
tsdPtr->flags = WIN_THREAD_BLOCKED;
@@ -871,22 +879,22 @@ Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
tsdPtr->prevPtr = winCondPtr->lastPtr; /* A: */
winCondPtr->lastPtr = tsdPtr;
if (tsdPtr->prevPtr != NULL) {
- tsdPtr->prevPtr->nextPtr = tsdPtr;
+ tsdPtr->prevPtr->nextPtr = tsdPtr;
}
if (winCondPtr->firstPtr == NULL) {
- winCondPtr->firstPtr = tsdPtr;
+ winCondPtr->firstPtr = tsdPtr;
}
/*
* Unlock the caller's mutex and wait for the condition, or a timeout.
- * There is a minor issue here in that we don't count down the
- * timeout if we get notified, but another thread grabs the condition
- * before we do. In that race condition we'll wait again for the
- * full timeout. Timed waits are dubious anyway. Either you have
- * the locking protocol wrong and are masking a deadlock,
- * or you are using conditions to pause your thread.
+ * There is a minor issue here in that we don't count down the timeout if
+ * we get notified, but another thread grabs the condition before we do.
+ * In that race condition we'll wait again for the full timeout. Timed
+ * waits are dubious anyway. Either you have the locking protocol wrong
+ * and are masking a deadlock, or you are using conditions to pause your
+ * thread.
*/
-
+
LeaveCriticalSection(csPtr);
timeout = 0;
while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) {
@@ -899,32 +907,32 @@ Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
}
/*
- * Be careful on timeouts because the signal might arrive right around
- * the time limit and someone else could have taken us off the queue.
+ * Be careful on timeouts because the signal might arrive right around the
+ * time limit and someone else could have taken us off the queue.
*/
-
+
if (timeout) {
if (tsdPtr->flags & WIN_THREAD_RUNNING) {
timeout = 0;
} else {
/*
- * When dequeuing, we can leave the tsdPtr->nextPtr
- * and tsdPtr->prevPtr with dangling pointers because
- * they are reinitialilzed w/out reading them when the
- * thread is enqueued later.
+ * When dequeuing, we can leave the tsdPtr->nextPtr and
+ * tsdPtr->prevPtr with dangling pointers because they are
+ * reinitialilzed w/out reading them when the thread is enqueued
+ * later.
*/
- if (winCondPtr->firstPtr == tsdPtr) {
- winCondPtr->firstPtr = tsdPtr->nextPtr;
- } else {
- tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
- }
- if (winCondPtr->lastPtr == tsdPtr) {
- winCondPtr->lastPtr = tsdPtr->prevPtr;
- } else {
- tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
- }
- tsdPtr->flags = WIN_THREAD_RUNNING;
+ if (winCondPtr->firstPtr == tsdPtr) {
+ winCondPtr->firstPtr = tsdPtr->nextPtr;
+ } else {
+ tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
+ }
+ if (winCondPtr->lastPtr == tsdPtr) {
+ winCondPtr->lastPtr = tsdPtr->prevPtr;
+ } else {
+ tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
+ }
+ tsdPtr->flags = WIN_THREAD_RUNNING;
}
}
@@ -939,8 +947,8 @@ Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
*
* This procedure is invoked to signal a condition variable.
*
- * The mutex must be held during this call to avoid races,
- * but this interface does not enforce that.
+ * The mutex must be held during this call to avoid races, but this
+ * interface does not enforce that.
*
* Results:
* None.
@@ -961,9 +969,9 @@ Tcl_ConditionNotify(condPtr)
winCondPtr = *((WinCondition **)condPtr);
/*
- * Loop through all the threads waiting on the condition
- * and notify them (i.e., broadcast semantics). The queue
- * manipulation is guarded by the per-condition coordinating mutex.
+ * Loop through all the threads waiting on the condition and notify
+ * them (i.e., broadcast semantics). The queue manipulation is guarded
+ * by the per-condition coordinating mutex.
*/
EnterCriticalSection(&winCondPtr->condLock);
@@ -981,7 +989,7 @@ Tcl_ConditionNotify(condPtr)
LeaveCriticalSection(&winCondPtr->condLock);
} else {
/*
- * Noone has used the condition variable, so there are no waiters.
+ * No-one has used the condition variable, so there are no waiters.
*/
}
}
@@ -991,9 +999,9 @@ Tcl_ConditionNotify(condPtr)
*
* FinalizeConditionEvent --
*
- * This procedure is invoked to clean up the per-thread
- * event used to implement condition waiting.
- * This is only safe to call at the end of time.
+ * This procedure is invoked to clean up the per-thread event used to
+ * implement condition waiting. This is only safe to call at the end of
+ * time.
*
* Results:
* None.
@@ -1008,7 +1016,7 @@ static void
FinalizeConditionEvent(data)
ClientData data;
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) data;
tsdPtr->flags = WIN_THREAD_DEAD;
CloseHandle(tsdPtr->condEvent);
}
@@ -1018,8 +1026,8 @@ FinalizeConditionEvent(data)
*
* TclpFinalizeCondition --
*
- * This procedure is invoked to clean up a condition variable.
- * This is only safe to call at the end of time.
+ * This procedure is invoked to clean up a condition variable. This is
+ * only safe to call at the end of time.
*
* This assumes the Master Lock is held.
*
@@ -1039,10 +1047,10 @@ TclpFinalizeCondition(condPtr)
WinCondition *winCondPtr = *(WinCondition **)condPtr;
/*
- * Note - this is called long after the thread-local storage is
- * reclaimed. The per-thread condition waiting event is
- * reclaimed earlier in a per-thread exit handler, which is
- * called before thread local storage is reclaimed.
+ * Note - this is called long after the thread-local storage is reclaimed.
+ * The per-thread condition waiting event is reclaimed earlier in a
+ * per-thread exit handler, which is called before thread local storage is
+ * reclaimed.
*/
if (winCondPtr != NULL) {
@@ -1075,8 +1083,11 @@ void
TclpFreeAllocMutex(mutex)
Tcl_Mutex *mutex; /* The alloc mutex to free. */
{
- allocMutex* lockPtr = (allocMutex*) mutex;
- if (!lockPtr) return;
+ allocMutex *lockPtr = (allocMutex *) mutex;
+
+ if (!lockPtr) {
+ return;
+ }
DeleteCriticalSection(&lockPtr->wlock);
free(lockPtr);
}
@@ -1088,10 +1099,10 @@ TclpGetAllocCache(void)
if (!once) {
/*
- * We need to make sure that TclpFreeAllocCache is called
- * on each thread that calls this, but only on threads that
- * call this.
+ * We need to make sure that TclpFreeAllocCache is called on each
+ * thread that calls this, but only on threads that call this.
*/
+
tlsKey = TlsAlloc();
once = 1;
if (tlsKey == TLS_OUT_OF_INDEXES) {
@@ -1101,7 +1112,7 @@ TclpGetAllocCache(void)
result = TlsGetValue(tlsKey);
if ((result == NULL) && (GetLastError() != NO_ERROR)) {
- Tcl_Panic("TlsGetValue failed from TclpGetAllocCache!");
+ Tcl_Panic("TlsGetValue failed from TclpGetAllocCache!");
}
return result;
}
@@ -1112,7 +1123,7 @@ TclpSetAllocCache(void *ptr)
BOOL success;
success = TlsSetValue(tlsKey, ptr);
if (!success) {
- Tcl_Panic("TlsSetValue failed from TclpSetAllocCache!");
+ Tcl_Panic("TlsSetValue failed from TclpSetAllocCache!");
}
}
@@ -1122,28 +1133,38 @@ TclpFreeAllocCache(void *ptr)
BOOL success;
if (ptr != NULL) {
- /*
- * Called by us in TclpFinalizeThreadData when a thread exits
- * and destroys the tsd key which stores allocator caches.
- */
- TclFreeAllocCache(ptr);
- success = TlsSetValue(tlsKey, NULL);
- if (!success) {
- panic("TlsSetValue failed from TclpFreeAllocCache!");
- }
- } else if (once) {
- /*
- * Called by us in TclFinalizeThreadAlloc() during
- * the library finalization initiated from Tcl_Finalize()
- */
- success = TlsFree(tlsKey);
- if (!success) {
- Tcl_Panic("TlsFree failed from TclpFreeAllocCache!");
- }
- once = 0; /* reset for next time. */
+ /*
+ * Called by us in TclpFinalizeThreadData when a thread exits and
+ * destroys the tsd key which stores allocator caches.
+ */
+
+ TclFreeAllocCache(ptr);
+ success = TlsSetValue(tlsKey, NULL);
+ if (!success) {
+ panic("TlsSetValue failed from TclpFreeAllocCache!");
+ }
+ } else if (once) {
+ /*
+ * Called by us in TclFinalizeThreadAlloc() during the library
+ * finalization initiated from Tcl_Finalize()
+ */
+
+ success = TlsFree(tlsKey);
+ if (!success) {
+ Tcl_Panic("TlsFree failed from TclpFreeAllocCache!");
+ }
+ once = 0; /* reset for next time. */
}
}
#endif /* USE_THREAD_ALLOC */
#endif /* TCL_THREADS */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
index 25f4296..fc91e2b 100644
--- a/win/tclWinTime.c
+++ b/win/tclWinTime.c
@@ -1,31 +1,32 @@
/*
* tclWinTime.c --
*
- * Contains Windows specific versions of Tcl functions that
- * obtain time values from the operating system.
+ * Contains Windows specific versions of Tcl functions that obtain time
+ * values from the operating system.
*
* Copyright 1995-1998 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: tclWinTime.c,v 1.30 2005/05/10 18:35:43 kennykb Exp $
+ * RCS: @(#) $Id: tclWinTime.c,v 1.31 2005/07/24 22:56:51 dkf Exp $
*/
#include "tclInt.h"
-#define SECSPERDAY (60L * 60L * 24L)
-#define SECSPERYEAR (SECSPERDAY * 365L)
-#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY)
+#define SECSPERDAY (60L * 60L * 24L)
+#define SECSPERYEAR (SECSPERDAY * 365L)
+#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY)
/*
- * Number of samples over which to estimate the performance counter
+ * Number of samples over which to estimate the performance counter.
*/
-#define SAMPLES 64
+
+#define SAMPLES 64
/*
- * The following arrays contain the day of year for the last day of
- * each month, where index 1 is January.
+ * The following arrays contain the day of year for the last day of each
+ * month, where index 1 is January.
*/
static int normalDays[] = {
@@ -47,38 +48,29 @@ static Tcl_ThreadDataKey dataKey;
*/
typedef struct TimeInfo {
-
- CRITICAL_SECTION cs; /* Mutex guarding this structure */
-
+ CRITICAL_SECTION cs; /* Mutex guarding this structure. */
int initialized; /* Flag == 1 if this structure is
* initialized. */
-
- int perfCounterAvailable; /* Flag == 1 if the hardware has a
- * performance counter */
-
- HANDLE calibrationThread; /* Handle to the thread that keeps the
- * virtual clock calibrated. */
-
- HANDLE readyEvent; /* System event used to
- * trigger the requesting thread
- * when the clock calibration procedure
- * is initialized for the first time */
-
- HANDLE exitEvent; /* Event to signal out of an exit handler
- * to tell the calibration loop to
- * terminate */
-
- LARGE_INTEGER nominalFreq; /* Nominal frequency of the system
- * performance counter, that is, the value
- * returned from QueryPerformanceFrequency. */
+ int perfCounterAvailable; /* Flag == 1 if the hardware has a performance
+ * counter. */
+ HANDLE calibrationThread; /* Handle to the thread that keeps the virtual
+ * clock calibrated. */
+ HANDLE readyEvent; /* System event used to trigger the requesting
+ * thread when the clock calibration procedure
+ * is initialized for the first time. */
+ HANDLE exitEvent; /* Event to signal out of an exit handler to
+ * tell the calibration loop to terminate. */
+ LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance
+ * counter, that is, the value returned from
+ * QueryPerformanceFrequency. */
/*
- * The following values are used for calculating virtual time.
- * Virtual time is always equal to:
+ * The following values are used for calculating virtual time. Virtual
+ * time is always equal to:
* lastFileTime + (current perf counter - lastCounter)
* * 10000000 / curCounterFreq
- * and lastFileTime and lastCounter are updated any time that
- * virtual time is returned to a caller.
+ * and lastFileTime and lastCounter are updated any time that virtual time
+ * is returned to a caller.
*/
ULARGE_INTEGER fileTimeLastCall;
@@ -86,16 +78,14 @@ typedef struct TimeInfo {
LARGE_INTEGER curCounterFreq;
/*
- * Data used in developing the estimate of performance counter
- * frequency
+ * Data used in developing the estimate of performance counter frequency
*/
+
Tcl_WideUInt fileTimeSample[SAMPLES];
- /* Last 64 samples of system time */
+ /* Last 64 samples of system time. */
Tcl_WideInt perfCounterSample[SAMPLES];
- /* Last 64 samples of performance counter */
- int sampleNo; /* Current sample number */
-
-
+ /* Last 64 samples of performance counter. */
+ int sampleNo; /* Current sample number. */
} TimeInfo;
static TimeInfo timeInfo = {
@@ -125,38 +115,34 @@ static TimeInfo timeInfo = {
* Declarations for functions defined later in this file.
*/
-static struct tm * ComputeGMT _ANSI_ARGS_((const time_t *tp));
-static void StopCalibration _ANSI_ARGS_(( ClientData ));
-static DWORD WINAPI CalibrationThread _ANSI_ARGS_(( LPVOID arg ));
-static void UpdateTimeEachSecond _ANSI_ARGS_(( void ));
-static void ResetCounterSamples _ANSI_ARGS_((
- Tcl_WideUInt fileTime,
- Tcl_WideInt perfCounter,
- Tcl_WideInt perfFreq
- ));
-static Tcl_WideInt AccumulateSample _ANSI_ARGS_((
- Tcl_WideInt perfCounter,
- Tcl_WideUInt fileTime
- ));
-
-static void NativeScaleTime _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData));
-static void NativeGetTime _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData));
-
-/* TIP #233 (Virtualized Time)
- * Data for the time hooks, if any.
+static struct tm * ComputeGMT(const time_t *tp);
+static void StopCalibration(ClientData clientData);
+static DWORD WINAPI CalibrationThread(LPVOID arg);
+static void UpdateTimeEachSecond(void);
+static void ResetCounterSamples(Tcl_WideUInt fileTime,
+ Tcl_WideInt perfCounter, Tcl_WideInt perfFreq);
+static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter,
+ Tcl_WideUInt fileTime);
+static void NativeScaleTime(Tcl_Time* timebuf,
+ ClientData clientData);
+static void NativeGetTime(Tcl_Time* timebuf,
+ ClientData clientData);
+
+/*
+ * TIP #233 (Virtualized Time): Data for the time hooks, if any.
*/
-Tcl_GetTimeProc* tclGetTimeProcPtr = NativeGetTime;
-Tcl_ScaleTimeProc* tclScaleTimeProcPtr = NativeScaleTime;
-ClientData tclTimeClientData = NULL;
+Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime;
+Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime;
+ClientData tclTimeClientData = NULL;
/*
*----------------------------------------------------------------------
*
* TclpGetSeconds --
*
- * This procedure returns the number of seconds from the epoch.
- * On most Unix systems the epoch is Midnight Jan 1, 1970 GMT.
+ * This procedure returns the number of seconds from the epoch. On most
+ * Unix systems the epoch is Midnight Jan 1, 1970 GMT.
*
* Results:
* Number of seconds from the epoch.
@@ -171,8 +157,8 @@ unsigned long
TclpGetSeconds()
{
Tcl_Time t;
- /* Tcl_GetTime inlined */
- (*tclGetTimeProcPtr) (&t, tclTimeClientData);
+
+ (*tclGetTimeProcPtr) (&t, tclTimeClientData); /* Tcl_GetTime inlined. */
return t.sec;
}
@@ -181,11 +167,10 @@ TclpGetSeconds()
*
* TclpGetClicks --
*
- * This procedure returns a value that represents the highest
- * resolution clock available on the system. There are no
- * guarantees on what the resolution will be. In Tcl we will
- * call this value a "click". The start time is also system
- * dependant.
+ * This procedure returns a value that represents the highest resolution
+ * clock available on the system. There are no guarantees on what the
+ * resolution will be. In Tcl we will call this value a "click". The
+ * start time is also system dependant.
*
* Results:
* Number of clicks from some start time.
@@ -200,17 +185,16 @@ unsigned long
TclpGetClicks()
{
/*
- * Use the Tcl_GetTime abstraction to get the time in microseconds,
- * as nearly as we can, and return it.
+ * Use the Tcl_GetTime abstraction to get the time in microseconds, as
+ * nearly as we can, and return it.
*/
Tcl_Time now; /* Current Tcl time */
unsigned long retval; /* Value to return */
- /* Tcl_GetTime inlined */
- (*tclGetTimeProcPtr) (&now, tclTimeClientData);
+ (*tclGetTimeProcPtr) (&now, tclTimeClientData); /* Tcl_GetTime inlined */
- retval = ( now.sec * 1000000 ) + now.usec;
+ retval = (now.sec * 1000000) + now.usec;
return retval;
}
@@ -220,9 +204,8 @@ TclpGetClicks()
*
* TclpGetTimeZone --
*
- * Determines the current timezone. The method varies wildly
- * between different Platform implementations, so its hidden in
- * this function.
+ * Determines the current timezone. The method varies wildly between
+ * different Platform implementations, so its hidden in this function.
*
* Results:
* Minutes west of GMT.
@@ -234,8 +217,8 @@ TclpGetClicks()
*/
int
-TclpGetTimeZone (currentTime)
- unsigned long currentTime;
+TclpGetTimeZone(currentTime)
+ unsigned long currentTime;
{
int timeZone;
@@ -250,20 +233,19 @@ TclpGetTimeZone (currentTime)
*
* Tcl_GetTime --
*
- * Gets the current system time in seconds and microseconds
- * since the beginning of the epoch: 00:00 UCT, January 1, 1970.
+ * Gets the current system time in seconds and microseconds since the
+ * beginning of the epoch: 00:00 UCT, January 1, 1970.
*
* Results:
* Returns the current time in timePtr.
*
* Side effects:
- * On the first call, initializes a set of static variables to
- * keep track of the base value of the performance counter, the
- * corresponding wall clock (obtained through ftime) and the
- * frequency of the performance counter. Also spins a thread
- * whose function is to wake up periodically and monitor these
- * values, adjusting them as necessary to correct for drift
- * in the performance counter's oscillator.
+ * On the first call, initializes a set of static variables to keep track
+ * of the base value of the performance counter, the corresponding wall
+ * clock (obtained through ftime) and the frequency of the performance
+ * counter. Also spins a thread whose function is to wake up periodically
+ * and monitor these values, adjusting them as necessary to correct for
+ * drift in the performance counter's oscillator.
*
*----------------------------------------------------------------------
*/
@@ -280,9 +262,8 @@ Tcl_GetTime(timePtr)
*
* NativeScaleTime --
*
- * TIP #233
- * Scale from virtual time to the real-time. For native scaling the
- * relationship is 1:1 and nothing has to be done.
+ * TIP #233: Scale from virtual time to the real-time. For native scaling
+ * the relationship is 1:1 and nothing has to be done.
*
* Results:
* Scales the time in timePtr.
@@ -294,11 +275,13 @@ Tcl_GetTime(timePtr)
*/
static void
-NativeScaleTime (timePtr, clientData)
- Tcl_Time* timePtr;
- ClientData clientData;
+NativeScaleTime(timePtr, clientData)
+ Tcl_Time *timePtr;
+ ClientData clientData;
{
- /* Native scale is 1:1. Nothing is done */
+ /*
+ * Native scale is 1:1. Nothing is done.
+ */
}
/*
@@ -306,87 +289,81 @@ NativeScaleTime (timePtr, clientData)
*
* NativeGetTime --
*
- * TIP #233
- * Gets the current system time in seconds and microseconds
+ * TIP #233: Gets the current system time in seconds and microseconds
* since the beginning of the epoch: 00:00 UCT, January 1, 1970.
*
* Results:
* Returns the current time in timePtr.
*
* Side effects:
- * On the first call, initializes a set of static variables to
- * keep track of the base value of the performance counter, the
- * corresponding wall clock (obtained through ftime) and the
- * frequency of the performance counter. Also spins a thread
- * whose function is to wake up periodically and monitor these
- * values, adjusting them as necessary to correct for drift
- * in the performance counter's oscillator.
+ * On the first call, initializes a set of static variables to keep track
+ * of the base value of the performance counter, the corresponding wall
+ * clock (obtained through ftime) and the frequency of the performance
+ * counter. Also spins a thread whose function is to wake up periodically
+ * and monitor these values, adjusting them as necessary to correct for
+ * drift in the performance counter's oscillator.
*
*----------------------------------------------------------------------
*/
static void
-NativeGetTime (timePtr, clientData)
- Tcl_Time* timePtr;
- ClientData clientData;
+NativeGetTime(timePtr, clientData)
+ Tcl_Time *timePtr;
+ ClientData clientData;
{
-
struct timeb t;
-
- int useFtime = 1; /* Flag == TRUE if we need to fall back
- * on ftime rather than using the perf
- * counter */
-
- /* Initialize static storage on the first trip through. */
+ int useFtime = 1; /* Flag == TRUE if we need to fall back on
+ * ftime rather than using the perf counter. */
/*
- * Note: Outer check for 'initialized' is a performance win
- * since it avoids an extra mutex lock in the common case.
+ * Initialize static storage on the first trip through.
+ *
+ * Note: Outer check for 'initialized' is a performance win since it
+ * avoids an extra mutex lock in the common case.
*/
- if ( !timeInfo.initialized ) {
+ if (!timeInfo.initialized) {
TclpInitLock();
- if ( !timeInfo.initialized ) {
- timeInfo.perfCounterAvailable
- = QueryPerformanceFrequency( &timeInfo.nominalFreq );
+ if (!timeInfo.initialized) {
+ timeInfo.perfCounterAvailable =
+ QueryPerformanceFrequency(&timeInfo.nominalFreq);
/*
- * Some hardware abstraction layers use the CPU clock
- * in place of the real-time clock as a performance counter
- * reference. This results in:
+ * Some hardware abstraction layers use the CPU clock in place of
+ * the real-time clock as a performance counter reference. This
+ * results in:
* - inconsistent results among the processors on
* multi-processor systems.
- * - unpredictable changes in performance counter frequency
- * on "gearshift" processors such as Transmeta and
- * SpeedStep.
+ * - unpredictable changes in performance counter frequency on
+ * "gearshift" processors such as Transmeta and SpeedStep.
*
* There seems to be no way to test whether the performance
- * counter is reliable, but a useful heuristic is that
- * if its frequency is 1.193182 MHz or 3.579545 MHz, it's
- * derived from a colorburst crystal and is therefore
- * the RTC rather than the TSC.
+ * counter is reliable, but a useful heuristic is that if its
+ * frequency is 1.193182 MHz or 3.579545 MHz, it's derived from a
+ * colorburst crystal and is therefore the RTC rather than the
+ * TSC.
*
- * A sloppier but serviceable heuristic is that the RTC crystal
- * is normally less than 15 MHz while the TSC crystal is
- * virtually assured to be greater than 100 MHz. Since Win98SE
- * appears to fiddle with the definition of the perf counter
- * frequency (perhaps in an attempt to calibrate the clock?)
- * we use the latter rule rather than an exact match.
+ * A sloppier but serviceable heuristic is that the RTC crystal is
+ * normally less than 15 MHz while the TSC crystal is virtually
+ * assured to be greater than 100 MHz. Since Win98SE appears to
+ * fiddle with the definition of the perf counter frequency
+ * (perhaps in an attempt to calibrate the clock?), we use the
+ * latter rule rather than an exact match.
*
- * We also assume (perhaps questionably) that the vendors
- * have gotten their act together on Win64, so bypass all
- * this rubbish on that platform.
+ * We also assume (perhaps questionably) that the vendors have
+ * gotten their act together on Win64, so bypass all this rubbish
+ * on that platform.
*/
#if !defined(_WIN64)
- if ( timeInfo.perfCounterAvailable
- /* The following lines would do an exact match on
- * crystal frequency:
- * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt) 1193182
- * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt) 3579545
- */
- && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000 ) {
-
+ if (timeInfo.perfCounterAvailable
+ /*
+ * The following lines would do an exact match on crystal
+ * frequency:
+ * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)1193182
+ * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)3579545
+ */
+ && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000){
/*
* As an exception, if every logical processor on the system
* is on the same chip, we use the performance counter anyway,
@@ -396,27 +373,22 @@ NativeGetTime (timePtr, clientData)
SYSTEM_INFO systemInfo;
unsigned int regs[4];
- GetSystemInfo( &systemInfo );
- if ( TclWinCPUID( 0, regs ) == TCL_OK
- && regs[1] == 0x756e6547 /* "Genu" */
- && regs[3] == 0x49656e69 /* "ineI" */
- && regs[2] == 0x6c65746e /* "ntel" */
-
- && TclWinCPUID( 1, regs ) == TCL_OK
-
- && ( (regs[0] & 0x00000F00) == 0x00000F00 /* Pentium 4 */
- || ( (regs[0] & 0x00F00000) /* Extended family */
- && (regs[3] & 0x10000000) ) ) /* Hyperthread */
- && ( ( ( regs[1] & 0x00FF0000 ) >> 16 ) /* CPU count */
- == systemInfo.dwNumberOfProcessors )
-
- ) {
+ GetSystemInfo(&systemInfo);
+ if (TclWinCPUID(0, regs) == TCL_OK
+ && regs[1] == 0x756e6547 /* "Genu" */
+ && regs[3] == 0x49656e69 /* "ineI" */
+ && regs[2] == 0x6c65746e /* "ntel" */
+ && TclWinCPUID(1, regs) == TCL_OK
+ && ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */
+ || ((regs[0] & 0x00F00000) /* Extended family */
+ && (regs[3] & 0x10000000))) /* Hyperthread */
+ && (((regs[1]&0x00FF0000) >> 16)/* CPU count */
+ == systemInfo.dwNumberOfProcessors)) {
timeInfo.perfCounterAvailable = TRUE;
} else {
timeInfo.perfCounterAvailable = FALSE;
}
-
}
#endif /* above code is Win32 only */
@@ -425,93 +397,85 @@ NativeGetTime (timePtr, clientData)
* calibrate it.
*/
- if ( timeInfo.perfCounterAvailable ) {
+ if (timeInfo.perfCounterAvailable) {
DWORD id;
- InitializeCriticalSection( &timeInfo.cs );
- timeInfo.readyEvent = CreateEvent( NULL, FALSE, FALSE, NULL );
- timeInfo.exitEvent = CreateEvent( NULL, FALSE, FALSE, NULL );
- timeInfo.calibrationThread = CreateThread( NULL,
- 256,
- CalibrationThread,
- (LPVOID) NULL,
- 0,
- &id );
- SetThreadPriority( timeInfo.calibrationThread,
- THREAD_PRIORITY_HIGHEST );
+
+ InitializeCriticalSection(&timeInfo.cs);
+ timeInfo.readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+ timeInfo.exitEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+ timeInfo.calibrationThread = CreateThread(NULL, 256,
+ CalibrationThread, (LPVOID) NULL, 0, &id);
+ SetThreadPriority(timeInfo.calibrationThread,
+ THREAD_PRIORITY_HIGHEST);
/*
- * Wait for the thread just launched to start running,
- * and create an exit handler that kills it so that it
- * doesn't outlive unloading tclXX.dll
+ * Wait for the thread just launched to start running, and
+ * create an exit handler that kills it so that it doesn't
+ * outlive unloading tclXX.dll
*/
- WaitForSingleObject( timeInfo.readyEvent, INFINITE );
- CloseHandle( timeInfo.readyEvent );
- Tcl_CreateExitHandler( StopCalibration, (ClientData) NULL );
+ WaitForSingleObject(timeInfo.readyEvent, INFINITE);
+ CloseHandle(timeInfo.readyEvent);
+ Tcl_CreateExitHandler(StopCalibration, (ClientData) NULL);
}
timeInfo.initialized = TRUE;
}
TclpInitUnlock();
}
- if ( timeInfo.perfCounterAvailable
- && timeInfo.curCounterFreq.QuadPart!=0 ) {
-
+ if (timeInfo.perfCounterAvailable && timeInfo.curCounterFreq.QuadPart!=0) {
/*
- * Query the performance counter and use it to calculate the
- * current time.
+ * Query the performance counter and use it to calculate the current
+ * time.
*/
LARGE_INTEGER curCounter;
- /* Current performance counter */
-
- Tcl_WideInt curFileTime;
- /* Current estimated time, expressed
- * as 100-ns ticks since the Windows epoch */
-
+ /* Current performance counter. */
+ Tcl_WideInt curFileTime;/* Current estimated time, expressed as 100-ns
+ * ticks since the Windows epoch. */
static LARGE_INTEGER posixEpoch;
- /* Posix epoch expressed as 100-ns ticks
- * since the windows epoch */
-
+ /* Posix epoch expressed as 100-ns ticks since
+ * the windows epoch. */
Tcl_WideInt usecSincePosixEpoch;
- /* Current microseconds since Posix epoch */
+ /* Current microseconds since Posix epoch. */
posixEpoch.LowPart = 0xD53E8000;
posixEpoch.HighPart = 0x019DB1DE;
- EnterCriticalSection( &timeInfo.cs );
+ EnterCriticalSection(&timeInfo.cs);
- QueryPerformanceCounter( &curCounter );
+ QueryPerformanceCounter(&curCounter);
/*
* If it appears to be more than 1.1 seconds since the last trip
- * through the calibration loop, the performance counter may
- * have jumped forward. (See MSDN Knowledge Base article
- * Q274323 for a description of the hardware problem that makes
- * this test necessary.) If the counter jumps, we don't want
- * to use it directly. Instead, we must return system time.
- * Eventually, the calibration loop should recover.
+ * through the calibration loop, the performance counter may have
+ * jumped forward. (See MSDN Knowledge Base article Q274323 for a
+ * description of the hardware problem that makes this test
+ * necessary.) If the counter jumps, we don't want to use it directly.
+ * Instead, we must return system time. Eventually, the calibration
+ * loop should recover.
*/
- if ( curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart
- < 11 * timeInfo.curCounterFreq.QuadPart / 10 ) {
-
- curFileTime = timeInfo.fileTimeLastCall.QuadPart
- + ( ( curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart )
- * 10000000 / timeInfo.curCounterFreq.QuadPart );
+
+ if (curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart <
+ 11 * timeInfo.curCounterFreq.QuadPart / 10) {
+ curFileTime = timeInfo.fileTimeLastCall.QuadPart +
+ ((curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart)
+ * 10000000 / timeInfo.curCounterFreq.QuadPart);
timeInfo.fileTimeLastCall.QuadPart = curFileTime;
timeInfo.perfCounterLastCall.QuadPart = curCounter.QuadPart;
- usecSincePosixEpoch = ( curFileTime - posixEpoch.QuadPart ) / 10;
- timePtr->sec = (time_t) ( usecSincePosixEpoch / 1000000 );
- timePtr->usec = (unsigned long ) ( usecSincePosixEpoch % 1000000 );
+ usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10;
+ timePtr->sec = (time_t) (usecSincePosixEpoch / 1000000);
+ timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
useFtime = 0;
}
- LeaveCriticalSection( &timeInfo.cs );
+ LeaveCriticalSection(&timeInfo.cs);
}
- if ( useFtime ) {
-
- /* High resolution timer is not available. Just use ftime */
+ if (useFtime) {
+ /*
+ * High resolution timer is not available. Just use ftime.
+ */
ftime(&t);
timePtr->sec = t.time;
@@ -531,24 +495,26 @@ NativeGetTime (timePtr, clientData)
* None.
*
* Side effects:
- * Sets the 'exitEvent' event in the 'timeInfo' structure to ask
- * the thread in question to exit, and waits for it to do so.
+ * Sets the 'exitEvent' event in the 'timeInfo' structure to ask the
+ * thread in question to exit, and waits for it to do so.
*
*----------------------------------------------------------------------
*/
static void
-StopCalibration( ClientData unused )
+StopCalibration(ClientData unused)
/* Client data is unused */
{
- SetEvent( timeInfo.exitEvent );
+ SetEvent(timeInfo.exitEvent);
+
/*
- * If Tcl_Finalize was called from DllMain, the calibration thread
- * is in a paused state so we need to timeout and continue.
+ * If Tcl_Finalize was called from DllMain, the calibration thread is in a
+ * paused state so we need to timeout and continue.
*/
- WaitForSingleObject( timeInfo.calibrationThread, 100 );
- CloseHandle( timeInfo.exitEvent );
- CloseHandle( timeInfo.calibrationThread );
+
+ WaitForSingleObject(timeInfo.calibrationThread, 100);
+ CloseHandle(timeInfo.exitEvent);
+ CloseHandle(timeInfo.calibrationThread);
}
/*
@@ -581,9 +547,9 @@ TclpGetTZName(int dst)
* tzset() under Borland doesn't seem to set up tzname[] at all.
* tzset() under MSVC has the following weird observed behavior:
* First time we call "clock format [clock seconds] -format %Z -gmt 1"
- * we get "GMT", but on all subsequent calls we get the current time
- * zone string, even though env(TZ) is GMT and the variable _timezone
- * is 0.
+ * we get "GMT", but on all subsequent calls we get the current time
+ * ezone string, even though env(TZ) is GMT and the variable _timezone
+ * is 0.
*/
name[0] = '\0';
@@ -591,11 +557,10 @@ TclpGetTZName(int dst)
zone = getenv("TZ");
if (zone != NULL) {
/*
- * TZ is of form "NST-4:30NDT", where "NST" would be the
- * name of the standard time zone for this area, "-4:30" is
- * the offset from GMT in hours, and "NDT is the name of
- * the daylight savings time zone in this area. The offset
- * and DST strings are optional.
+ * TZ is of form "NST-4:30NDT", where "NST" would be the name of the
+ * standard time zone for this area, "-4:30" is the offset from GMT in
+ * hours, and "NDT is the name of the daylight savings time zone in
+ * this area. The offset and DST strings are optional.
*/
len = strlen(zone);
@@ -623,9 +588,10 @@ TclpGetTZName(int dst)
if (name[0] == '\0') {
if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) {
/*
- * MSDN: On NT this is returned if DST is not used in
- * the current TZ
+ * MSDN: On NT this is returned if DST is not used in the current
+ * TZ
*/
+
dst = 0;
}
encoding = Tcl_GetEncoding(NULL, "unicode");
@@ -642,9 +608,9 @@ TclpGetTZName(int dst)
*
* TclpGetDate --
*
- * This function converts between seconds and struct tm. If
- * useGMT is true, then the returned date will be in Greenwich
- * Mean Time (GMT). Otherwise, it will be in the local time zone.
+ * This function converts between seconds and struct tm. If useGMT is
+ * true, then the returned date will be in Greenwich Mean Time (GMT).
+ * Otherwise, it will be in the local time zone.
*
* Results:
* Returns a static tm structure.
@@ -667,25 +633,29 @@ TclpGetDate(t, useGMT)
tzset();
/*
- * If we are in the valid range, let the C run-time library
- * handle it. Otherwise we need to fake it. Note that this
- * algorithm ignores daylight savings time before the epoch.
+ * If we are in the valid range, let the C run-time library handle it.
+ * Otherwise we need to fake it. Note that this algorithm ignores
+ * daylight savings time before the epoch.
*/
/*
- Hm, Borland's localtime manages to return NULL under certain
- circumstances (e.g. wintime.test, test 1.2). Nobody tests for this,
- since 'localtime' isn't supposed to do this, possibly leading to
- crashes.
- Patch: We only call this function if we are at least one day into
- the epoch, else we handle it ourselves (like we do for times < 0).
- H. Giese, June 2003
- */
+ * Hm, Borland's localtime manages to return NULL under certain
+ * circumstances (e.g. wintime.test, test 1.2). Nobody tests for this,
+ * since 'localtime' isn't supposed to do this, possibly leading to
+ * crashes.
+ *
+ * Patch: We only call this function if we are at least one day into
+ * the epoch, else we handle it ourselves (like we do for times < 0).
+ * H. Giese, June 2003
+ */
+
#ifdef __BORLANDC__
- if (*t >= SECSPERDAY) {
+#define LOCALTIME_VALIDITY_BOUNDARY SECSPERDAY
#else
- if (*t >= 0) {
+#define LOCALTIME_VALIDITY_BOUNDARY 0
#endif
+
+ if (*t >= LOCALTIME_VALIDITY_BOUNDARY) {
return TclpLocaltime(t);
}
@@ -693,12 +663,11 @@ TclpGetDate(t, useGMT)
/*
* If we aren't near to overflowing the long, just add the bias and
- * use the normal calculation. Otherwise we will need to adjust
- * the result at the end.
+ * use the normal calculation. Otherwise we will need to adjust the
+ * result at the end.
*/
- if (*t < (LONG_MAX - 2 * SECSPERDAY)
- && *t > (LONG_MIN + 2 * SECSPERDAY)) {
+ if (*t < (LONG_MAX - 2*SECSPERDAY) && *t > (LONG_MIN + 2*SECSPERDAY)) {
tmPtr = ComputeGMT(&time);
} else {
tmPtr = ComputeGMT(t);
@@ -747,8 +716,8 @@ TclpGetDate(t, useGMT)
*
* ComputeGMT --
*
- * This function computes GMT given the number of seconds since
- * the epoch (midnight Jan 1 1970).
+ * This function computes GMT given the number of seconds since the epoch
+ * (midnight Jan 1 1970).
*
* Results:
* Returns a (per thread) statically allocated struct tm.
@@ -788,9 +757,9 @@ ComputeGMT(tp)
}
/*
- * Compute the year after 1900 by taking the 4 year span and adjusting
- * for the remainder. This works because 2000 is a leap year, and
- * 1900/2100 are out of the range.
+ * Compute the year after 1900 by taking the 4 year span and adjusting for
+ * the remainder. This works because 2000 is a leap year, and 1900/2100
+ * are out of the range.
*/
tmp = (tmp * 4) + 70;
@@ -812,8 +781,8 @@ ComputeGMT(tp)
tmPtr->tm_year = tmp;
/*
- * Compute the day of year and leave the seconds in the current day in
- * the remainder.
+ * Compute the day of year and leave the seconds in the current day in the
+ * remainder.
*/
tmPtr->tm_yday = rem / SECSPERDAY;
@@ -834,6 +803,7 @@ ComputeGMT(tp)
days = (isLeap) ? leapDays : normalDays;
for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) {
+ /* empty body */
}
tmPtr->tm_mon = --tmp;
tmPtr->tm_mday = tmPtr->tm_yday - days[tmp];
@@ -859,60 +829,65 @@ ComputeGMT(tp)
*
* CalibrationThread --
*
- * Thread that manages calibration of the hi-resolution time
- * derived from the performance counter, to keep it synchronized
- * with the system clock.
+ * Thread that manages calibration of the hi-resolution time derived from
+ * the performance counter, to keep it synchronized with the system
+ * clock.
*
* Parameters:
- * arg -- Client data from the CreateThread call. This parameter
- * points to the static TimeInfo structure.
+ * arg - Client data from the CreateThread call. This parameter points to
+ * the static TimeInfo structure.
*
* Return value:
- * None. This thread embeds an infinite loop.
+ * None. This thread embeds an infinite loop.
*
* Side effects:
- * At an interval of 1 s, this thread performs virtual time discipline.
+ * At an interval of 1s, this thread performs virtual time discipline.
*
- * Note: When this thread is entered, TclpInitLock has been called
- * to safeguard the static storage. There is therefore no synchronization
- * in the body of this procedure.
+ * Note: When this thread is entered, TclpInitLock has been called to
+ * safeguard the static storage. There is therefore no synchronization in the
+ * body of this procedure.
*
*----------------------------------------------------------------------
*/
static DWORD WINAPI
-CalibrationThread( LPVOID arg )
+CalibrationThread(LPVOID arg)
{
FILETIME curFileTime;
DWORD waitResult;
- /* Get initial system time and performance counter */
+ /*
+ * Get initial system time and performance counter.
+ */
- GetSystemTimeAsFileTime( &curFileTime );
- QueryPerformanceCounter( &timeInfo.perfCounterLastCall );
- QueryPerformanceFrequency( &timeInfo.curCounterFreq );
+ GetSystemTimeAsFileTime(&curFileTime);
+ QueryPerformanceCounter(&timeInfo.perfCounterLastCall);
+ QueryPerformanceFrequency(&timeInfo.curCounterFreq);
timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;
- ResetCounterSamples( timeInfo.fileTimeLastCall.QuadPart,
- timeInfo.perfCounterLastCall.QuadPart,
- timeInfo.curCounterFreq.QuadPart );
+ ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart,
+ timeInfo.perfCounterLastCall.QuadPart,
+ timeInfo.curCounterFreq.QuadPart);
/*
- * Wake up the calling thread. When it wakes up, it will release the
+ * Wake up the calling thread. When it wakes up, it will release the
* initialization lock.
*/
- SetEvent( timeInfo.readyEvent );
+ SetEvent(timeInfo.readyEvent);
- /* Run the calibration once a second */
+ /*
+ * Run the calibration once a second.
+ */
while (timeInfo.perfCounterAvailable) {
-
- /* If the exitEvent is set, break out of the loop. */
+ /*
+ * If the exitEvent is set, break out of the loop.
+ */
waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE);
- if ( waitResult == WAIT_OBJECT_0 ) {
+ if (waitResult == WAIT_OBJECT_0) {
break;
}
UpdateTimeEachSecond();
@@ -927,11 +902,11 @@ CalibrationThread( LPVOID arg )
*
* UpdateTimeEachSecond --
*
- * Callback from the waitable timer in the clock calibration thread
- * that updates system time.
+ * Callback from the waitable timer in the clock calibration thread that
+ * updates system time.
*
* Parameters:
- * info -- Pointer to the static TimeInfo structure
+ * info - Pointer to the static TimeInfo structure
*
* Results:
* None.
@@ -945,127 +920,114 @@ CalibrationThread( LPVOID arg )
static void
UpdateTimeEachSecond()
{
-
LARGE_INTEGER curPerfCounter;
/* Current value returned from
- * QueryPerformanceCounter */
-
- FILETIME curSysTime; /* Current system time */
-
- LARGE_INTEGER curFileTime; /* File time at the time this callback
- * was scheduled. */
-
- Tcl_WideInt estFreq; /* Estimated perf counter frequency */
-
- Tcl_WideInt vt0; /* Tcl time right now */
- Tcl_WideInt vt1; /* Tcl time one second from now */
-
- Tcl_WideInt tdiff; /* Difference between system clock and
- * Tcl time. */
-
- Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time
- * into step over 1 second */
+ * QueryPerformanceCounter. */
+ FILETIME curSysTime; /* Current system time. */
+ LARGE_INTEGER curFileTime; /* File time at the time this callback was
+ * scheduled. */
+ Tcl_WideInt estFreq; /* Estimated perf counter frequency. */
+ Tcl_WideInt vt0; /* Tcl time right now. */
+ Tcl_WideInt vt1; /* Tcl time one second from now. */
+ Tcl_WideInt tdiff; /* Difference between system clock and Tcl
+ * time. */
+ Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time into
+ * step over 1 second. */
/*
* Sample performance counter and system time.
*/
- QueryPerformanceCounter( &curPerfCounter );
- GetSystemTimeAsFileTime( &curSysTime );
+ QueryPerformanceCounter(&curPerfCounter);
+ GetSystemTimeAsFileTime(&curSysTime);
curFileTime.LowPart = curSysTime.dwLowDateTime;
curFileTime.HighPart = curSysTime.dwHighDateTime;
- EnterCriticalSection( &timeInfo.cs );
+ EnterCriticalSection(&timeInfo.cs);
/*
- * We devide by timeInfo.curCounterFreq.QuadPart in several places.
- * That value should always be positive on a correctly functioning
- * system. But it is good to be defensive about such matters.
- * So if something goes wrong and the value does goes to zero, we
- * clear the timeInfo.perfCounterAvailable in order to cause the
- * calibration thread to shut itself down, then return without additional
- * processing.
+ * We devide by timeInfo.curCounterFreq.QuadPart in several places. That
+ * value should always be positive on a correctly functioning system. But
+ * it is good to be defensive about such matters. So if something goes
+ * wrong and the value does goes to zero, we clear the
+ * timeInfo.perfCounterAvailable in order to cause the calibration thread
+ * to shut itself down, then return without additional processing.
*/
- if( timeInfo.curCounterFreq.QuadPart==0 ){
- LeaveCriticalSection( &timeInfo.cs );
+ if (timeInfo.curCounterFreq.QuadPart == 0){
+ LeaveCriticalSection(&timeInfo.cs);
timeInfo.perfCounterAvailable = 0;
return;
}
/*
- * Several things may have gone wrong here that have to
- * be checked for.
- * (1) The performance counter may have jumped.
- * (2) The system clock may have been reset.
+ * Several things may have gone wrong here that have to be checked for.
+ * (1) The performance counter may have jumped.
+ * (2) The system clock may have been reset.
*
- * In either case, we'll need to reinitialize the circular buffer
- * with samples relative to the current system time and the NOMINAL
- * performance frequency (not the actual, because the actual has
- * probably run slow in the first case). Our estimated frequency
- * will be the nominal frequency.
- */
-
- /*
- * Store the current sample into the circular buffer of samples,
- * and estimate the performance counter frequency.
+ * In either case, we'll need to reinitialize the circular buffer with
+ * samples relative to the current system time and the NOMINAL performance
+ * frequency (not the actual, because the actual has probably run slow in
+ * the first case). Our estimated frequency will be the nominal frequency.
+ *
+ * Store the current sample into the circular buffer of samples, and
+ * estimate the performance counter frequency.
*/
- estFreq = AccumulateSample( curPerfCounter.QuadPart,
- (Tcl_WideUInt) curFileTime.QuadPart );
+ estFreq = AccumulateSample(curPerfCounter.QuadPart,
+ (Tcl_WideUInt) curFileTime.QuadPart);
/*
* We want to adjust things so that time appears to be continuous.
- * Virtual file time, right now, is
+ * Virtual file time, right now, is
*
- * vt0 = 10000000 * ( curPerfCounter - perfCounterLastCall )
- * / curCounterFreq
- * + fileTimeLastCall
+ * vt0 = 10000000 * (curPerfCounter - perfCounterLastCall)
+ * / curCounterFreq
+ * + fileTimeLastCall
*
- * Ideally, we would like to drift the clock into place over a
- * period of 2 sec, so that virtual time 2 sec from now will be
+ * Ideally, we would like to drift the clock into place over a period of 2
+ * sec, so that virtual time 2 sec from now will be
*
* vt1 = 20000000 + curFileTime
*
- * The frequency that we need to use to drift the counter back into
- * place is estFreq * 20000000 / ( vt1 - vt0 )
+ * The frequency that we need to use to drift the counter back into place
+ * is estFreq * 20000000 / (vt1 - vt0)
*/
- vt0 = 10000000 * ( curPerfCounter.QuadPart
- - timeInfo.perfCounterLastCall.QuadPart )
- / timeInfo.curCounterFreq.QuadPart
- + timeInfo.fileTimeLastCall.QuadPart;
+ vt0 = 10000000 * (curPerfCounter.QuadPart
+ - timeInfo.perfCounterLastCall.QuadPart)
+ / timeInfo.curCounterFreq.QuadPart
+ + timeInfo.fileTimeLastCall.QuadPart;
vt1 = 20000000 + curFileTime.QuadPart;
/*
- * If we've gotten more than a second away from system time,
- * then drifting the clock is going to be pretty hopeless.
- * Just let it jump. Otherwise, compute the drift frequency and
- * fill in everything.
+ * If we've gotten more than a second away from system time, then drifting
+ * the clock is going to be pretty hopeless. Just let it jump. Otherwise,
+ * compute the drift frequency and fill in everything.
*/
tdiff = vt0 - curFileTime.QuadPart;
- if ( tdiff > 10000000 || tdiff < -10000000 ) {
+ if (tdiff > 10000000 || tdiff < -10000000) {
timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart;
timeInfo.curCounterFreq.QuadPart = estFreq;
} else {
- driftFreq = estFreq * 20000000 / ( vt1 - vt0 );
- if ( driftFreq > 1003 * estFreq / 1000 ) {
- driftFreq = 1003 * estFreq / 1000;
- }
- if ( driftFreq < 997 * estFreq / 1000 ) {
- driftFreq = 997 * estFreq / 1000;
+ driftFreq = estFreq * 20000000 / (vt1 - vt0);
+
+ if (driftFreq > 1003*estFreq/1000) {
+ driftFreq = 1003*estFreq/1000;
+ } else if (driftFreq < 997*estFreq/1000) {
+ driftFreq = 997*estFreq/1000;
}
+
timeInfo.fileTimeLastCall.QuadPart = vt0;
timeInfo.curCounterFreq.QuadPart = driftFreq;
}
timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart;
- LeaveCriticalSection( &timeInfo.cs );
-
+ LeaveCriticalSection(&timeInfo.cs);
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1078,23 +1040,21 @@ UpdateTimeEachSecond()
* None.
*
* Side effects:
- * The array of samples is filled in so that it appears that there
- * are SAMPLES samples at one-second intervals, separated by precisely
- * the given frequency.
+ * The array of samples is filled in so that it appears that there are
+ * SAMPLES samples at one-second intervals, separated by precisely the
+ * given frequency.
*
*----------------------------------------------------------------------
*/
static void
-ResetCounterSamples( Tcl_WideUInt fileTime,
- /* Current file time */
- Tcl_WideInt perfCounter,
- /* Current performance counter */
- Tcl_WideInt perfFreq )
- /* Target performance frequency */
+ResetCounterSamples(
+ Tcl_WideUInt fileTime, /* Current file time */
+ Tcl_WideInt perfCounter, /* Current performance counter */
+ Tcl_WideInt perfFreq) /* Target performance frequency */
{
int i;
- for ( i = SAMPLES-1; i >= 0; --i ) {
+ for (i=SAMPLES-1 ; i>=0 ; --i) {
timeInfo.perfCounterSample[i] = perfCounter;
timeInfo.fileTimeSample[i] = fileTime;
perfCounter -= perfFreq;
@@ -1108,84 +1068,79 @@ ResetCounterSamples( Tcl_WideUInt fileTime,
*
* AccumulateSample --
*
- * Updates the circular buffer of performance counter and system
- * time samples with a new data point.
+ * Updates the circular buffer of performance counter and system time
+ * samples with a new data point.
*
* Results:
* None.
*
* Side effects:
- * The new data point replaces the oldest point in the circular
- * buffer, and the descriptive statistics are updated to accumulate
- * the new point.
- *
- * Several things may have gone wrong here that have to
- * be checked for.
- * (1) The performance counter may have jumped.
- * (2) The system clock may have been reset.
- *
- * In either case, we'll need to reinitialize the circular buffer
- * with samples relative to the current system time and the NOMINAL
- * performance frequency (not the actual, because the actual has
- * probably run slow in the first case).
+ * The new data point replaces the oldest point in the circular buffer,
+ * and the descriptive statistics are updated to accumulate the new
+ * point.
+ *
+ * Several things may have gone wrong here that have to be checked for.
+ * (1) The performance counter may have jumped.
+ * (2) The system clock may have been reset.
+ *
+ * In either case, we'll need to reinitialize the circular buffer with samples
+ * relative to the current system time and the NOMINAL performance frequency
+ * (not the actual, because the actual has probably run slow in the first
+ * case).
*/
static Tcl_WideInt
-AccumulateSample( Tcl_WideInt perfCounter,
- Tcl_WideUInt fileTime )
+AccumulateSample(Tcl_WideInt perfCounter, Tcl_WideUInt fileTime)
{
- Tcl_WideUInt workFTSample; /* File time sample being removed
- * from or added to the circular buffer */
-
- Tcl_WideInt workPCSample; /* Performance counter sample being
- * removed from or added to the circular
- * buffer */
-
+ Tcl_WideUInt workFTSample; /* File time sample being removed from or
+ * added to the circular buffer. */
+ Tcl_WideInt workPCSample; /* Performance counter sample being removed
+ * from or added to the circular buffer. */
Tcl_WideUInt lastFTSample; /* Last file time sample recorded */
-
Tcl_WideInt lastPCSample; /* Last performance counter sample recorded */
-
Tcl_WideInt FTdiff; /* Difference between last FT and current */
-
Tcl_WideInt PCdiff; /* Difference between last PC and current */
-
Tcl_WideInt estFreq; /* Estimated performance counter frequency */
- /* Test for jumps and reset the samples if we have one. */
+ /*
+ * Test for jumps and reset the samples if we have one.
+ */
- if ( timeInfo.sampleNo == 0 ) {
- lastPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo
- + SAMPLES - 1 ];
- lastFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo
- + SAMPLES - 1 ];
+ if (timeInfo.sampleNo == 0) {
+ lastPCSample =
+ timeInfo.perfCounterSample[timeInfo.sampleNo + SAMPLES - 1];
+ lastFTSample =
+ timeInfo.fileTimeSample[timeInfo.sampleNo + SAMPLES - 1];
} else {
- lastPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo - 1 ];
- lastFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo - 1 ];
+ lastPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo - 1];
+ lastFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo - 1];
}
+
PCdiff = perfCounter - lastPCSample;
FTdiff = fileTime - lastFTSample;
- if ( PCdiff < timeInfo.nominalFreq.QuadPart * 9 / 10
- || PCdiff > timeInfo.nominalFreq.QuadPart * 11 / 10
- || FTdiff < 9000000
- || FTdiff > 11000000 ) {
- ResetCounterSamples( fileTime, perfCounter,
- timeInfo.nominalFreq.QuadPart );
+ if (PCdiff < timeInfo.nominalFreq.QuadPart * 9 / 10
+ || PCdiff > timeInfo.nominalFreq.QuadPart * 11 / 10
+ || FTdiff < 9000000 || FTdiff > 11000000) {
+ ResetCounterSamples(fileTime, perfCounter,
+ timeInfo.nominalFreq.QuadPart);
return timeInfo.nominalFreq.QuadPart;
-
} else {
-
- /* Estimate the frequency */
+ /*
+ * Estimate the frequency.
+ */
- workPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo ];
- workFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo ];
- estFreq = 10000000 * ( perfCounter - workPCSample )
- / ( fileTime - workFTSample );
- timeInfo.perfCounterSample[ timeInfo.sampleNo ] = perfCounter;
- timeInfo.fileTimeSample[ timeInfo.sampleNo ] = (Tcl_WideInt) fileTime;
+ workPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo];
+ workFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo];
+ estFreq = 10000000 * (perfCounter - workPCSample)
+ / (fileTime - workFTSample);
+ timeInfo.perfCounterSample[timeInfo.sampleNo] = perfCounter;
+ timeInfo.fileTimeSample[timeInfo.sampleNo] = (Tcl_WideInt) fileTime;
- /* Advance the sample number */
+ /*
+ * Advance the sample number.
+ */
- if ( ++timeInfo.sampleNo >= SAMPLES ) {
+ if (++timeInfo.sampleNo >= SAMPLES) {
timeInfo.sampleNo = 0;
}
@@ -1198,8 +1153,7 @@ AccumulateSample( Tcl_WideInt perfCounter,
*
* TclpGmtime --
*
- * Wrapper around the 'gmtime' library function to make it thread
- * safe.
+ * Wrapper around the 'gmtime' library function to make it thread safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
@@ -1211,17 +1165,17 @@ AccumulateSample( Tcl_WideInt perfCounter,
*/
struct tm *
-TclpGmtime( timePtr )
- CONST time_t *timePtr; /* Pointer to the number of seconds
- * since the local system's epoch */
-
+TclpGmtime(timePtr)
+ CONST time_t *timePtr; /* Pointer to the number of seconds since the
+ * local system's epoch */
{
/*
- * The MS implementation of gmtime is thread safe because
- * it returns the time in a block of thread-local storage,
- * and Windows does not provide a Posix gmtime_r function.
+ * The MS implementation of gmtime is thread safe because it returns the
+ * time in a block of thread-local storage, and Windows does not provide a
+ * Posix gmtime_r function.
*/
- return gmtime( timePtr );
+
+ return gmtime(timePtr);
}
/*
@@ -1242,17 +1196,18 @@ TclpGmtime( timePtr )
*/
struct tm *
-TclpLocaltime( timePtr )
- CONST time_t *timePtr; /* Pointer to the number of seconds
- * since the local system's epoch */
+TclpLocaltime(timePtr)
+ CONST time_t *timePtr; /* Pointer to the number of seconds since the
+ * local system's epoch */
{
/*
- * The MS implementation of localtime is thread safe because
- * it returns the time in a block of thread-local storage,
- * and Windows does not provide a Posix localtime_r function.
+ * The MS implementation of localtime is thread safe because it returns
+ * the time in a block of thread-local storage, and Windows does not
+ * provide a Posix localtime_r function.
*/
- return localtime( timePtr );
+
+ return localtime(timePtr);
}
/*
@@ -1260,9 +1215,8 @@ TclpLocaltime( timePtr )
*
* Tcl_SetTimeProc --
*
- * TIP #233 (Virtualized Time)
- * Registers two handlers for the virtualization of Tcl's
- * access to time information.
+ * TIP #233 (Virtualized Time): Registers two handlers for the
+ * virtualization of Tcl's access to time information.
*
* Results:
* None.
@@ -1274,14 +1228,14 @@ TclpLocaltime( timePtr )
*/
void
-Tcl_SetTimeProc (getProc, scaleProc, clientData)
- Tcl_GetTimeProc* getProc;
- Tcl_ScaleTimeProc* scaleProc;
- ClientData clientData;
+Tcl_SetTimeProc(getProc, scaleProc, clientData)
+ Tcl_GetTimeProc *getProc;
+ Tcl_ScaleTimeProc *scaleProc;
+ ClientData clientData;
{
- tclGetTimeProcPtr = getProc;
+ tclGetTimeProcPtr = getProc;
tclScaleTimeProcPtr = scaleProc;
- tclTimeClientData = clientData;
+ tclTimeClientData = clientData;
}
/*
@@ -1289,8 +1243,7 @@ Tcl_SetTimeProc (getProc, scaleProc, clientData)
*
* Tcl_QueryTimeProc --
*
- * TIP #233 (Virtualized Time)
- * Query which time handlers are registered.
+ * TIP #233 (Virtualized Time): Query which time handlers are registered.
*
* Results:
* None.
@@ -1302,19 +1255,26 @@ Tcl_SetTimeProc (getProc, scaleProc, clientData)
*/
void
-Tcl_QueryTimeProc (getProc, scaleProc, clientData)
- Tcl_GetTimeProc** getProc;
- Tcl_ScaleTimeProc** scaleProc;
- ClientData* clientData;
+Tcl_QueryTimeProc(getProc, scaleProc, clientData)
+ Tcl_GetTimeProc ** getProc;
+ Tcl_ScaleTimeProc **scaleProc;
+ ClientData *clientData;
{
if (getProc) {
- *getProc = tclGetTimeProcPtr;
+ *getProc = tclGetTimeProcPtr;
}
if (scaleProc) {
- *scaleProc = tclScaleTimeProcPtr;
+ *scaleProc = tclScaleTimeProcPtr;
}
if (clientData) {
- *clientData = tclTimeClientData;
+ *clientData = tclTimeClientData;
}
}
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
generated by cgit v0.12 at 2024-11-02 06:28:51 (GMT)