From 88304e7e4a0cf2399fa92d3a6ccfa127603299fa Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Jul 2005 22:56:43 +0000 Subject: Getting more systematic about style --- generic/tclConfig.c | 256 ++--- generic/tclFCmd.c | 615 ++++++------ generic/tclGet.c | 80 +- generic/tclPreserve.c | 272 +++--- generic/tclResult.c | 541 ++++++----- generic/tclStringObj.c | 995 ++++++++++---------- generic/tclThreadAlloc.c | 194 ++-- generic/tclTimer.c | 596 ++++++------ generic/tclUtil.c | 1486 ++++++++++++++--------------- unix/tclUnixNotfy.c | 407 ++++---- unix/tclUnixPipe.c | 531 +++++------ unix/tclXtNotify.c | 291 +++--- win/tclAppInit.c | 159 ++-- win/tclWin32Dll.c | 1220 ++++++++++++------------ win/tclWinChan.c | 511 +++++----- win/tclWinConsole.c | 440 ++++----- win/tclWinDde.c | 292 +++--- win/tclWinFCmd.c | 1127 +++++++++++----------- win/tclWinFile.c | 2344 ++++++++++++++++++++++++++-------------------- win/tclWinInit.c | 196 ++-- win/tclWinLoad.c | 169 ++-- win/tclWinNotify.c | 234 ++--- win/tclWinPipe.c | 1289 +++++++++++++------------ win/tclWinReg.c | 363 +++---- win/tclWinSerial.c | 689 +++++++------- win/tclWinSock.c | 1391 ++++++++++++++------------- win/tclWinThrd.c | 485 +++++----- win/tclWinTime.c | 894 +++++++++--------- 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 * - * 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 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 ; iclientData == 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 ; iclientData != 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 +/* + * 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, ¬ifierMutex, myTimePtr); + Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, 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(¬ifierMutex); -#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(¬ifierMutex); @@ -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 #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(¬ifier, 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 - * 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 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 /* - * 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 /* 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. + * + * 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. * - * This routine reads a NTFS junction, using the undocumented - * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points - * and junctions. + * 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. * - * Read the junction/reparse information from a given NTFS directory. + * Assumption that LinkDirectory is a valid, existing 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= '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= 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(¬ifierMutex); @@ -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(¬ifierMutex); @@ -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 /* - * 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: + */ -- cgit v0.12