diff options
51 files changed, 1750 insertions, 637 deletions
diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index 19cb467..c3edfa4 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -331,11 +331,11 @@ trace procedures will always be invoked. .SH "RESTRICTIONS" .PP A trace procedure can be called at any time, even when there -is a partially formed result in the interpreter's result area. If +are partially formed results stored in the interpreter. If the trace procedure does anything that could damage this result (such -as calling \fBTcl_Eval\fR) then it must save the original values of -the interpreter's \fBresult\fR and \fBfreeProc\fR fields and restore -them before it returns. +as calling \fBTcl_Eval\fR) then it must use the \fBTcl_SaveInterpState\fR +and related routines to save and restore the original state of +the interpreter before it returns. .SH "UNDEFINED VARIABLES" .PP It is legal to set a trace on an undefined variable. @@ -433,6 +433,36 @@ If \fIname\fR contains no separators then returns \fIname\fR. So, \fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all return \fBb\fR. .TP +\fBfile tempdir\fR ?\fItemplate\fR? +.VS "8.7, TIP 431" +Creates a temporary directory (guaranteed to be newly created and writable by +the current script) and returns its name. If \fItemplate\fR is given, it +specifies one of or both of the existing directory (on a filesystem controlled +by the operating system) to contain the temporary directory, and the base part +of the directory name; it is considered to have the location of the directory +if there is a directory separator in the name, and the base part is everything +after the last directory separator (if non-empty). The default containing +directory is determined by system-specific operations, and the default base +name prefix is +.QW \fBtcl\fR . +.RS +.PP +The following output is typical and illustrative; the actual output will vary +between platforms: +.PP +.CS +% \fBfile tempdir\fR +/var/tmp/tcl_u0kuy5 + % \fBfile tempdir\fR /tmp/myapp +/tmp/myapp_8o7r9L +% \fBfile tempdir\fR /tmp/ +/tmp/tcl_1mOJHD +% \fBfile tempdir\fR myapp +/var/tmp/myapp_0ihS0n +.CE +.RE +.VE "8.7, TIP 431" +.TP \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? '\" TIP #210 .VS 8.6 diff --git a/doc/timerate.n b/doc/timerate.n index 636d9de..c5fdf30 100644 --- a/doc/timerate.n +++ b/doc/timerate.n @@ -41,7 +41,7 @@ iterations is reached or the time is exceeded. It will then return a canonical tcl-list of the form: .PP .CS -\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 nett-ms\fR +\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 net-ms\fR .CE .PP which indicates: diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 0117055..d7eaf80 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -173,7 +173,7 @@ static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRInjectObjCmd; static Tcl_NRPostProc NRPostInvoke; - +static Tcl_ObjCmdProc CoroTypeObjCmd; static Tcl_ObjCmdProc TclNRCoroInjectObjCmd; static Tcl_ObjCmdProc TclNRCoroProbeObjCmd; static Tcl_NRPostProc InjectHandler; @@ -372,6 +372,7 @@ static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { {"file", "size"}, {"file", "stat"}, {"file", "tail"}, + {"file", "tempdir"}, {"file", "tempfile"}, {"file", "type"}, {"file", "volumes"}, @@ -980,8 +981,11 @@ Tcl_CreateInterp(void) TclNRAssembleObjCmd, NULL, NULL); cmdPtr->compileProc = &TclCompileAssembleCmd; + /* Coroutine monkeybusiness */ Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, NRInjectObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype", + CoroTypeObjCmd, NULL, NULL); /* Export unsupported commands */ nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0); @@ -2384,14 +2388,16 @@ Tcl_CreateCommand( break; } - /* An existing command conflicts. Try to delete it.. */ + /* + * An existing command conflicts. Try to delete it... + */ + cmdPtr = Tcl_GetHashValue(hPtr); /* - * Be careful to preserve - * any existing import links so we can restore them down below. That - * way, you can redefine a command and its import status will remain - * intact. + * Be careful to preserve any existing import links so we can restore + * them down below. That way, you can redefine a command and its + * import status will remain intact. */ cmdPtr->refCount++; @@ -2411,16 +2417,15 @@ Tcl_CreateCommand( if (!isNew) { /* - * If the deletion callback recreated the command, just throw away - * the new command (if we try to delete it again, we could get - * stuck in an infinite loop). + * If the deletion callback recreated the command, just throw away the + * new command (if we try to delete it again, we could get stuck in an + * infinite loop). */ ckfree(Tcl_GetHashValue(hPtr)); } if (!deleted) { - /* * Command resolvers (per-interp, per-namespace) might have resolved * to a command for the given namespace scope with this command not @@ -2603,17 +2608,17 @@ TclCreateObjCommandInNs( } /* - * An existing command conflicts. Try to delete it. + * An existing command conflicts. Try to delete it... */ cmdPtr = Tcl_GetHashValue(hPtr); /* - * [***] This is wrong. See Tcl Bug a16752c252. However, this buggy - * behavior is kept under particular circumstances to accommodate - * deployed binaries of the "tclcompiler" program - * http://sourceforge.net/projects/tclpro/ - * that crash if the bug is fixed. + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular circumstances + * to accommodate deployed binaries of the "tclcompiler" program + * <http://sourceforge.net/projects/tclpro/> that crash if the bug is + * fixed. */ if (cmdPtr->objProc == TclInvokeStringCommand @@ -4613,15 +4618,22 @@ EvalObjvCore( reresolve: assert(cmdPtr == NULL); if (preCmdPtr) { - /* Caller gave it to us */ + /* + * Caller gave it to us. + */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { - /* So long as it exists, use it. */ + /* + * So long as it exists, use it. + */ + cmdPtr = preCmdPtr; } else if (flags & TCL_EVAL_NORESOLVE) { /* - * When it's been deleted, and we're told not to attempt - * resolving it ourselves, all we can do is raise an error. + * When it's been deleted, and we're told not to attempt resolving + * it ourselves, all we can do is raise an error. */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to invoke a deleted command")); Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); @@ -4637,14 +4649,12 @@ EvalObjvCore( if (enterTracesDone || iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - Tcl_Obj *commandPtr = TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, objc, objv); - Tcl_IncrRefCount(commandPtr); + Tcl_IncrRefCount(commandPtr); if (!enterTracesDone) { - int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, objc, objv); @@ -4652,10 +4662,10 @@ EvalObjvCore( * Send any exception from enter traces back as an exception * raised by the traced command. * TODO: Is this a bug? Letting an execution trace BREAK or - * CONTINUE or RETURN in the place of the traced command? - * Would either converting all exceptions to TCL_ERROR, or - * just swallowing them be better? (Swallowing them has the - * problem of permanently hiding program errors.) + * CONTINUE or RETURN in the place of the traced command? Would + * either converting all exceptions to TCL_ERROR, or just + * swallowing them be better? (Swallowing them has the problem of + * permanently hiding program errors.) */ if (code != TCL_OK) { @@ -4664,9 +4674,8 @@ EvalObjvCore( } /* - * If the enter traces made the resolved cmdPtr unusable, go - * back and resolve again, but next time don't run enter - * traces again. + * If the enter traces made the resolved cmdPtr unusable, go back + * and resolve again, but next time don't run enter traces again. */ if (cmdPtr == NULL) { @@ -4677,9 +4686,9 @@ EvalObjvCore( } /* - * Schedule leave traces. Raise the refCount on the resolved - * cmdPtr, so that when it passes to the leave traces we know - * it's still valid. + * Schedule leave traces. Raise the refCount on the resolved cmdPtr, + * so that when it passes to the leave traces we know it's still + * valid. */ cmdPtr->refCount++; @@ -4749,8 +4758,6 @@ TclNRRunCallbacks( #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Interp *iPtr = (Interp *) interp; #endif /* !defined(TCL_NO_DEPRECATED) */ - NRE_callback *callbackPtr; - Tcl_NRPostProc *procPtr; /* * If the interpreter has a non-empty string result, the result object is @@ -4768,11 +4775,14 @@ TclNRRunCallbacks( } #endif /* !defined(TCL_NO_DEPRECATED) */ - /* This is the trampoline. */ + /* + * This is the trampoline. + */ while (TOP_CB(interp) != rootPtr) { - callbackPtr = TOP_CB(interp); - procPtr = callbackPtr->procPtr; + NRE_callback *callbackPtr = TOP_CB(interp); + Tcl_NRPostProc *procPtr = callbackPtr->procPtr; + TOP_CB(interp) = callbackPtr->nextPtr; result = procPtr(callbackPtr->data, interp, result); TCLNR_FREE(interp, callbackPtr); @@ -6980,14 +6990,17 @@ TclNRInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); - /* Avoid the exception-handling brain damage when numLevels == 0 . */ + /* + * Avoid the exception-handling brain damage when numLevels == 0 + */ + iPtr->numLevels++; Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); /* * Normal command resolution of objv[0] isn't going to find cmdPtr. - * That's the whole point of **hidden** commands. So tell the - * Eval core machinery not to even try (and risk finding something wrong). + * That's the whole point of **hidden** commands. So tell the Eval core + * machinery not to even try (and risk finding something wrong). */ return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); @@ -8381,13 +8394,21 @@ TclDTraceInfo( Tcl_DictObjGet(NULL, info, *k++, &val); args[i] = val ? TclGetString(val) : NULL; } - /* no "proc" -> use "lambda" */ + + /* + * no "proc" -> use "lambda" + */ + if (!args[2]) { Tcl_DictObjGet(NULL, info, *k, &val); args[2] = val ? TclGetString(val) : NULL; } k++; - /* no "class" -> use "object" */ + + /* + * no "class" -> use "object" + */ + if (!args[5]) { Tcl_DictObjGet(NULL, info, *k, &val); args[5] = val ? TclGetString(val) : NULL; @@ -8741,8 +8762,10 @@ TclNRTailcallObjCmd( Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - /* The tailcall data is in a Tcl list: the first element is the - * namespace, the rest the command to be tailcalled. */ + /* + * The tailcall data is in a Tcl list: the first element is the + * namespace, the rest the command to be tailcalled. + */ nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); listPtr = Tcl_NewListObj(objc, objv); @@ -9193,6 +9216,75 @@ TclNREvalList( /* *---------------------------------------------------------------------- * + * CoroTypeObjCmd -- + * + * Implementation of [::tcl::unsupported::corotype] command. + * + *---------------------------------------------------------------------- + */ + +static int +CoroTypeObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr; + CoroutineData *corPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "coroName"); + return TCL_ERROR; + } + + /* + * Look up the coroutine. + */ + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); + if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only get coroutine type of a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), NULL); + return TCL_ERROR; + } + + /* + * An active coroutine is "active". Can't tell what it might do in the + * future. + */ + + corPtr = cmdPtr->objClientData; + if (!COR_IS_SUSPENDED(corPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1)); + return TCL_OK; + } + + /* + * Inactive coroutines are classified by the (effective) command used to + * suspend them, which matters when you're injecting a probe. + */ + + switch (corPtr->nargs) { + case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: + Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1)); + return TCL_OK; + case COROUTINE_ARGUMENTS_ARBITRARY: + Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1)); + return TCL_OK; + default: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown coroutine type", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd -- * * Implementation of [coroinject] and [coroprobe] commands. @@ -9676,9 +9768,12 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - /* ensure that the command is looked up in the correct namespace */ + /* + * Ensure that the command is looked up in the correct namespace. + */ + iPtr->lookupNsPtr = lookupNsPtr; - Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); + Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0); iPtr->numLevels--; SAVE_CONTEXT(corPtr->running); diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 1f78d18..246c371 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -771,7 +771,10 @@ TclAppendBytesToByteArray( "TclAppendBytesToByteArray"); } if (len == 0) { - /* Append zero bytes is a no-op. */ + /* + * Append zero bytes is a no-op. + */ + return; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1811c5c..dd98ef3 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1093,6 +1093,7 @@ TclInitFileCmd( {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1}, {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index ef7a42c..c11534e 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -56,7 +56,7 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); * The following structure is used to pass this information. */ -typedef struct SortInfo { +typedef struct { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ @@ -566,7 +566,7 @@ InfoBodyCmd( * the object do not invalidate the internal rep. */ - bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes); + bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes); Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); return TCL_OK; } @@ -1047,7 +1047,7 @@ InfoErrorStackCmd( target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + target = Tcl_GetSlave(interp, TclGetString(objv[1])); if (target == NULL) { return TCL_ERROR; } @@ -2155,7 +2155,7 @@ InfoCmdTypeCmd( Tcl_WrongNumArgs(interp, 1, objv, "commandName"); return TCL_ERROR; } - command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, + command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL, TCL_LEAVE_ERR_MSG); if (command == NULL) { return TCL_ERROR; @@ -2231,7 +2231,7 @@ Tcl_JoinObjCmd( joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - (void) Tcl_GetStringFromObj(joinObjPtr, &length); + (void) TclGetStringFromObj(joinObjPtr, &length); if (length == 0) { resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); } else { @@ -2721,15 +2721,13 @@ Tcl_LrangeObjCmd( *---------------------------------------------------------------------- */ -typedef int list_index_t; - static int LremoveIndexCompare( const void *el1Ptr, const void *el2Ptr) { - list_index_t idx1 = *((const list_index_t *) el1Ptr); - list_index_t idx2 = *((const list_index_t *) el2Ptr); + int idx1 = *((const int *) el1Ptr); + int idx2 = *((const int *) el2Ptr); /* * This will put the larger element first. @@ -2746,7 +2744,7 @@ Tcl_LremoveObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int i, idxc; - list_index_t listLen, *idxv, prevIdx, first, num; + int listLen, *idxv, prevIdx, first, num; Tcl_Obj *listObj; /* @@ -2768,7 +2766,7 @@ Tcl_LremoveObjCmd( Tcl_SetObjResult(interp, listObj); return TCL_OK; } - idxv = ckalloc((objc - 2) * sizeof(list_index_t)); + idxv = ckalloc((objc - 2) * sizeof(int)); for (i = 2; i < objc; i++) { if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, &idxv[i - 2]) != TCL_OK) { @@ -2783,7 +2781,7 @@ Tcl_LremoveObjCmd( */ if (idxc > 1) { - qsort(idxv, idxc, sizeof(list_index_t), LremoveIndexCompare); + qsort(idxv, idxc, sizeof(int), LremoveIndexCompare); } /* @@ -2796,7 +2794,7 @@ Tcl_LremoveObjCmd( num = 0; first = listLen; for (i = 0, prevIdx = -1 ; i < idxc ; i++) { - list_index_t idx = idxv[i]; + int idx = idxv[i]; /* * Repeated index and sanity check. @@ -3003,7 +3001,7 @@ Tcl_LreplaceObjCmd( return result; } - if (first < 0) { + if (first == TCL_INDEX_NONE) { first = 0; } if (first > listLen) { @@ -3382,10 +3380,10 @@ Tcl_LsearchObjCmd( TCL_INDEX_NONE, &encoded) != TCL_OK) { result = TCL_ERROR; } - if (encoded == TCL_INDEX_NONE) { + if (encoded == (int)TCL_INDEX_NONE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indices[j]))); + "from any list", TclGetString(indices[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; @@ -3515,8 +3513,8 @@ Tcl_LsearchObjCmd( if (result != TCL_OK) { goto done; } - if (start < 0) { - start = 0; + if (start == TCL_INDEX_NONE) { + start = TCL_INDEX_START; } /* @@ -4099,10 +4097,10 @@ Tcl_LsortObjCmd( int result = TclIndexEncode(interp, indexv[j], TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded); - if ((result == TCL_OK) && (encoded == TCL_INDEX_NONE)) { + if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indexv[j]))); + "from any list", TclGetString(indexv[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; @@ -4859,7 +4857,7 @@ SelectObjFromSublist( return NULL; } if (currentObj == NULL) { - if (index == TCL_INDEX_NONE) { + if (index == (int)TCL_INDEX_NONE) { index = TCL_INDEX_END - infoPtr->indexv[i]; Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( "element end-%d missing from sublist \"%s\"", diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 6792378..455b44c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4188,6 +4188,7 @@ Tcl_TimeRateObjCmd( }; NRE_callback *rootPtr; ByteCode *codePtr = NULL; + int codeOptimized = 0; for (i = 1; i < objc - 1; i++) { int index; @@ -4372,6 +4373,15 @@ Tcl_TimeRateObjCmd( } codePtr = TclCompileObj(interp, objPtr, NULL, 0); TclPreserveByteCode(codePtr); + /* + * Replace last compiled done instruction with continue: it's a part of + * iteration, this way evaluation will be more similar to a cycle (also + * avoids extra overhead to set result to interp, etc.) + */ + if (codePtr->codeStart[codePtr->numCodeBytes-1] == INST_DONE) { + codePtr->codeStart[codePtr->numCodeBytes-1] = INST_CONTINUE; + codeOptimized = 1; + } } /* @@ -4418,23 +4428,25 @@ Tcl_TimeRateObjCmd( } else { /* eval */ result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); } - if (result != TCL_OK) { - /* - * Allow break from measurement cycle (used for conditional - * stop). - */ + /* + * Allow break and continue from measurement cycle (used for + * conditional stop and flow control of iterations). + */ - if (result != TCL_BREAK) { + switch (result) { + case TCL_OK: + break; + case TCL_BREAK: + /* + * Force stop immediately. + */ + threshold = 1; + maxcnt = 0; + case TCL_CONTINUE: + result = TCL_OK; + break; + default: goto done; - } - - /* - * Force stop immediately. - */ - - threshold = 1; - maxcnt = 0; - result = TCL_OK; } /* @@ -4534,17 +4546,20 @@ Tcl_TimeRateObjCmd( { Tcl_Obj *objarr[8], **objs = objarr; - Tcl_WideInt val; + Tcl_WideUInt usec, val; int digits; - middle -= start; /* execution time in microsecs */ + /* + * Absolute execution time in microseconds or in wide clicks. + */ + usec = (Tcl_WideUInt)(middle - start); #ifdef TCL_WIDE_CLICKS /* - * convert execution time in wide clicks to microsecs. + * convert execution time (in wide clicks) to microsecs. */ - middle *= TclpWideClickInMicrosec(); + usec *= TclpWideClickInMicrosec(); #endif /* TCL_WIDE_CLICKS */ if (!count) { /* no iterations - avoid divide by zero */ @@ -4568,10 +4583,10 @@ Tcl_TimeRateObjCmd( Tcl_WideUInt curOverhead = overhead * count; - if (middle > (Tcl_WideInt) curOverhead) { - middle -= curOverhead; + if (usec > curOverhead) { + usec -= curOverhead; } else { - middle = 0; + usec = 0; } } } else { @@ -4579,15 +4594,15 @@ Tcl_TimeRateObjCmd( * Calibration: obtaining new measurement overhead. */ - if (measureOverhead > ((double) middle) / count) { - measureOverhead = ((double) middle) / count; + if (measureOverhead > ((double) usec) / count) { + measureOverhead = ((double) usec) / count; } objs[0] = Tcl_NewDoubleObj(measureOverhead); TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */ objs += 2; } - val = middle / count; /* microsecs per iteration */ + val = usec / count; /* microsecs per iteration */ if (val >= 1000000) { objs[0] = Tcl_NewWideIntObj(val); } else { @@ -4602,7 +4617,7 @@ Tcl_TimeRateObjCmd( } else { digits = 1; } - objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) middle)/count); + objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count); } objs[2] = Tcl_NewWideIntObj(count); /* iterations */ @@ -4611,11 +4626,11 @@ Tcl_TimeRateObjCmd( * Calculate speed as rate (count) per sec */ - if (!middle) { - middle++; /* Avoid divide by zero. */ + if (!usec) { + usec++; /* Avoid divide by zero. */ } if (count < (WIDE_MAX / 1000000)) { - val = (count * 1000000) / middle; + val = (count * 1000000) / usec; if (val < 100000) { if (val < 100) { digits = 3; @@ -4625,12 +4640,12 @@ Tcl_TimeRateObjCmd( digits = 1; } objs[4] = Tcl_ObjPrintf("%.*f", - digits, ((double) (count * 1000000)) / middle); + digits, ((double) (count * 1000000)) / usec); } else { objs[4] = Tcl_NewWideIntObj(val); } } else { - objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000); + objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000); } retRes: @@ -4639,12 +4654,12 @@ Tcl_TimeRateObjCmd( */ if (!calibrate) { - if (middle >= 1) { - objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000); + if (usec >= 1) { + objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000); } else { objs[6] = Tcl_NewWideIntObj(0); } - TclNewLiteralStringObj(objs[7], "nett-ms"); + TclNewLiteralStringObj(objs[7], "net-ms"); } /* @@ -4660,6 +4675,11 @@ Tcl_TimeRateObjCmd( done: if (codePtr != NULL) { + if ( codeOptimized + && codePtr->codeStart[codePtr->numCodeBytes-1] == INST_CONTINUE + ) { + codePtr->codeStart[codePtr->numCodeBytes-1] = INST_DONE; + } TclReleaseByteCode(codePtr); } return result; diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 441611e..a8a85f8 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -433,7 +433,7 @@ TclCompileIfCmd( jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode); } } } @@ -606,7 +606,7 @@ TclCompileInfoCommandsCmd( if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { goto notCompilable; } - bytes = Tcl_GetString(objPtr); + bytes = TclGetString(objPtr); /* * We require that the argument start with "::" and not have any of "*\[?" @@ -1038,7 +1038,7 @@ TclCompileLassignCmd( */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1243,7 +1243,7 @@ TclCompileListCmd( if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); } return TCL_OK; } @@ -1319,7 +1319,7 @@ TclCompileLrangeCmd( tokenPtr = TokenAfter(listTokenPtr); if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &idx1) != TCL_OK) || (idx1 == TCL_INDEX_NONE)) { + &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) { return TCL_ERROR; } /* @@ -1408,7 +1408,7 @@ TclCompileLinsertCmd( CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1418,10 +1418,10 @@ TclCompileLinsertCmd( } TclEmitInstInt4( INST_LIST, i - 3, envPtr); - if (idx == TCL_INDEX_START) { + if (idx == (int)TCL_INDEX_START) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == TCL_INDEX_END) { + } else if (idx == (int)TCL_INDEX_END) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { /* @@ -1436,7 +1436,7 @@ TclCompileLinsertCmd( * differ in their interpretation of the "end" index. */ - if (idx < TCL_INDEX_END) { + if (idx < (int)TCL_INDEX_END) { idx++; } TclEmitInstInt4( INST_OVER, 1, envPtr); @@ -1444,7 +1444,7 @@ TclCompileLinsertCmd( TclEmitInt4( idx - 1, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } @@ -1505,14 +1505,14 @@ TclCompileLreplaceCmd( * we must defer to direct evaluation. */ - if (idx1 == TCL_INDEX_NONE) { - suffixStart = TCL_INDEX_NONE; - } else if (idx2 == TCL_INDEX_NONE) { + if (idx1 == (int)TCL_INDEX_NONE) { + suffixStart = (int)TCL_INDEX_NONE; + } else if (idx2 == (int)TCL_INDEX_NONE) { suffixStart = idx1; - } else if (idx2 == TCL_INDEX_END) { - suffixStart = TCL_INDEX_NONE; - } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END)) - || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) { + } else if (idx2 == (int)TCL_INDEX_END) { + suffixStart = (int)TCL_INDEX_NONE; + } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END)) + || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) { suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; } else { return TCL_ERROR; @@ -1546,11 +1546,11 @@ TclCompileLreplaceCmd( * and canonicalization side effects. */ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } - if (idx1 != TCL_INDEX_START) { + if (idx1 != (int)TCL_INDEX_START) { /* Prefix may not be empty; generate bytecode to push it */ if (emptyPrefix) { TclEmitOpcode( INST_DUP, envPtr); @@ -1570,7 +1570,7 @@ TclCompileLreplaceCmd( TclEmitInstInt4( INST_REVERSE, 2, envPtr); } - if (suffixStart == TCL_INDEX_NONE) { + if (suffixStart == (int)TCL_INDEX_NONE) { TclEmitOpcode( INST_POP, envPtr); if (emptyPrefix) { PushStringLiteral(envPtr, ""); @@ -1578,7 +1578,7 @@ TclCompileLreplaceCmd( } else { /* Suffix may not be empty; generate bytecode to push it */ TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); if (!emptyPrefix) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } @@ -2295,8 +2295,8 @@ TclCompileRegsubCmd( if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - if (Tcl_GetString(patternObj)[0] == '-') { - if (strcmp(Tcl_GetString(patternObj), "--") != 0 + if (TclGetString(patternObj)[0] == '-') { + if (strcmp(TclGetString(patternObj), "--") != 0 || parsePtr->numWords == 5) { goto done; } @@ -2361,7 +2361,7 @@ TclCompileRegsubCmd( bytes++; } isSimpleGlob: - for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { + for (bytes = TclGetString(replacementObj); *bytes; bytes++) { switch (*bytes) { case '\\': case '&': goto done; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 4663fac..83ade0b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -482,16 +482,16 @@ TclCompileStringInsertCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); - if (idx == TCL_INDEX_START) { + if (idx == (int)TCL_INDEX_START) { /* Prepend the insertion string */ OP4( REVERSE, 2); OP1( STR_CONCAT1, 2); - } else if (idx == TCL_INDEX_END) { + } else if (idx == (int)TCL_INDEX_END) { /* Append the insertion string */ OP1( STR_CONCAT1, 2); } else { /* Prefix + insertion + suffix */ - if (idx < TCL_INDEX_END) { + if (idx < (int)TCL_INDEX_END) { /* See comments in compiler for [linsert]. */ idx++; } @@ -821,7 +821,7 @@ TclCompileStringMatchCmd( } str = tokenPtr[1].start; length = tokenPtr[1].size; - if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) { + if ((length <= 1) || strncmp(str, "-nocase", length)) { /* * Fail at run time, not in compilation. */ @@ -1012,7 +1012,7 @@ TclCompileStringRangeCmd( * the string the same as the start of the string. */ - if (idx1 == TCL_INDEX_NONE) { + if (idx1 == (int)TCL_INDEX_NONE) { /* [string range $s end+1 $last] must be empty string */ OP( POP); PUSH( ""); @@ -1027,7 +1027,7 @@ TclCompileStringRangeCmd( * Token parsed as an index expression. We treat all indices after * the string the same as the end of the string. */ - if (idx2 == TCL_INDEX_NONE) { + if (idx2 == (int)TCL_INDEX_NONE) { /* [string range $s $first -1] must be empty string */ OP( POP); PUSH( ""); @@ -1105,8 +1105,8 @@ TclCompileStringReplaceCmd( * compile direct to bytecode implementing the no-op. */ - if ((last == TCL_INDEX_NONE) /* Know (last < 0) */ - || (first == TCL_INDEX_NONE) /* Know (first > end) */ + if ((last == (int)TCL_INDEX_NONE) /* Know (last < 0) */ + || (first == (int)TCL_INDEX_NONE) /* Know (first > end) */ /* * Tricky to determine when runtime (last < first) can be @@ -1117,7 +1117,7 @@ TclCompileStringReplaceCmd( * (last <= TCL_INDEX END) && (last < first) => ACCEPT * else => cannot tell REJECT */ - || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END) + || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END) && (last < first)) /* Know (last < first) */ /* * (first == TCL_INDEX_NONE) && @@ -1128,7 +1128,7 @@ TclCompileStringReplaceCmd( * (last <= TCL_INDEX_END) => cannot tell REJECT * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT */ - || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START) + || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START) && (last < first))) { /* Know (last < first) */ if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); @@ -1179,7 +1179,7 @@ TclCompileStringReplaceCmd( * getting a guarantee that first <= last. */ - if ((first == TCL_INDEX_START) && (last >= TCL_INDEX_START)) { + if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) { /* empty prefix */ tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); @@ -1187,13 +1187,13 @@ TclCompileStringReplaceCmd( if (last == INT_MAX) { OP( POP); /* Pop original */ } else { - OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); OP1( STR_CONCAT1, 2); } return TCL_OK; } - if ((last == TCL_INDEX_NONE) && (first <= TCL_INDEX_END)) { + if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) { OP44( STR_RANGE_IMM, 0, first-1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); @@ -1210,19 +1210,19 @@ TclCompileStringReplaceCmd( * are harmless when they are replaced by another empty string. */ - if (first == TCL_INDEX_START) { + if (first == (int)TCL_INDEX_START) { /* empty prefix - build suffix only */ - if (last == TCL_INDEX_END) { + if (last == (int)TCL_INDEX_END) { /* empty suffix too => empty result */ OP( POP); /* Pop original */ PUSH ( ""); return TCL_OK; } - OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); return TCL_OK; } else { - if (last == TCL_INDEX_END) { + if (last == (int)TCL_INDEX_END) { /* empty suffix - build prefix only */ OP44( STR_RANGE_IMM, 0, first-1); return TCL_OK; @@ -1230,7 +1230,7 @@ TclCompileStringReplaceCmd( OP( DUP); OP44( STR_RANGE_IMM, 0, first-1); OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); OP1( STR_CONCAT1, 2); return TCL_OK; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3b67796..3d40bef 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3986,6 +3986,8 @@ extern const TclStubs *tclStubsPtr; #define Tcl_AddObjErrorInfo(interp, message, length) \ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) #ifdef TCL_NO_DEPRECATED +#undef Tcl_GetStringResult +#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) #undef Tcl_Eval #define Tcl_Eval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, -1, 0) diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index a4dded2..8ef0456 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1345,7 +1345,7 @@ TclFileReadLinkCmd( /* *--------------------------------------------------------------------------- * - * TclFileTemporaryCmd + * TclFileTemporaryCmd -- * * This function implements the "tempfile" subcommand of the "file" * command. @@ -1505,6 +1505,151 @@ TclFileTemporaryCmd( } /* + *--------------------------------------------------------------------------- + * + * TclFileTempDirCmd -- + * + * This function implements the "tempdir" subcommand of the "file" + * command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Creates a temporary directory. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileTempDirCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirNameObj; /* Object that will contain the directory + * name. */ + Tcl_Obj *baseDirObj = NULL, *nameBaseObj = NULL; + /* Pieces of template. Each piece is NULL if + * it is omitted. The platform temporary file + * engine might ignore some pieces. */ + + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?template?"); + return TCL_ERROR; + } + + if (objc > 1) { + int length; + Tcl_Obj *templateObj = objv[1]; + const char *string = TclGetStringFromObj(templateObj, &length); + const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS); + + /* + * Treat an empty string as if it wasn't there. + */ + + if (length == 0) { + goto makeTemporary; + } + + /* + * The template only gives a directory if there is a directory + * separator in it, and only gives a base name if there's at least one + * character after the last directory separator. + */ + + if (strchr(string, '/') == NULL + && (!onWindows || strchr(string, '\\') == NULL)) { + /* + * No directory separator, so just assume we have a file name. + * This is a bit wrong on Windows where we could have problems + * with disk name prefixes... but those are much less common in + * naked form so we just pass through and let the OS figure it out + * instead. + */ + + nameBaseObj = templateObj; + Tcl_IncrRefCount(nameBaseObj); + } else if (string[length-1] != '/' + && (!onWindows || string[length-1] != '\\')) { + /* + * If the template has a non-terminal directory separator, split + * into dirname and tail. + */ + + baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); + nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL); + } else { + /* + * Otherwise, there must be a terminal directory separator, so + * just the directory is given. + */ + + baseDirObj = templateObj; + Tcl_IncrRefCount(baseDirObj); + } + + /* + * Only allow creation of temporary directories in the native + * filesystem since they are frequently used for integration with + * external tools or system libraries. + */ + + if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj) + != &tclNativeFilesystem) { + TclDecrRefCount(baseDirObj); + baseDirObj = NULL; + } + } + + /* + * Convert empty parts of the template into unspecified parts. + */ + + if (baseDirObj && !TclGetString(baseDirObj)[0]) { + TclDecrRefCount(baseDirObj); + baseDirObj = NULL; + } + if (nameBaseObj && !TclGetString(nameBaseObj)[0]) { + TclDecrRefCount(nameBaseObj); + nameBaseObj = NULL; + } + + /* + * Create and open the temporary file. + */ + + makeTemporary: + dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj); + + /* + * If we created pieces of template, get rid of them now. + */ + + if (baseDirObj) { + TclDecrRefCount(baseDirObj); + } + if (nameBaseObj) { + TclDecrRefCount(nameBaseObj); + } + + /* + * Deal with results. + */ + + if (dirNameObj == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create temporary directory: %s", + Tcl_PosixError(interp))); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirNameObj); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclHash.c b/generic/tclHash.c index f7f9b32..6c21c59 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -311,7 +311,10 @@ CreateHashEntry( if (hash != PTR2UINT(hPtr->hash)) { continue; } - if (((void *) key == hPtr) || compareKeysProc((void *) key, hPtr)) { + /* if keys pointers or values are equal */ + if ((key == hPtr->key.oneWordValue) + || compareKeysProc((void *) key, hPtr) + ) { if (newPtr) { *newPtr = 0; } diff --git a/generic/tclIO.c b/generic/tclIO.c index cf91307..118820a 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3463,6 +3463,11 @@ Tcl_Close( Tcl_ClearChannelHandlers(chan); /* + * Cancel any outstanding timer. + */ + Tcl_DeleteTimerHandler(statePtr->timer); + + /* * Invoke the registered close callbacks and delete their records. */ @@ -4447,6 +4452,8 @@ Write( } } + UpdateInterest(chanPtr); + return total; } @@ -8475,9 +8482,9 @@ UpdateInterest( * * - Tcl drops READABLE here, because it has data in its own * buffers waiting to be read by the extension. - * - A READABLE event is syntesized via timer. + * - A READABLE event is synthesized via timer. * - The OS still reports the EXCEPTION condition on the file. - * - And the extension gets the EXCPTION event first, and handles + * - And the extension gets the EXCEPTION event first, and handles * this as EOF. * * End result ==> Premature end of reading from a file. @@ -8503,6 +8510,16 @@ UpdateInterest( } } } + + if (!statePtr->timer + && mask & TCL_WRITABLE + && GotFlag(statePtr, CHANNEL_NONBLOCKING)) { + + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); + } + + ChanWatch(chanPtr, mask); } @@ -8531,6 +8548,21 @@ ChannelTimerProc( ChannelState *statePtr = chanPtr->state; /* State info for channel */ + Tcl_Preserve(statePtr); + statePtr->timer = NULL; + if (statePtr->interestMask & TCL_WRITABLE + && GotFlag(statePtr, CHANNEL_NONBLOCKING) + && !GotFlag(statePtr, BG_FLUSH_SCHEDULED) + ) { + /* + * Restart the timer in case a channel handler reenters the event loop + * before UpdateInterest gets called by Tcl_NotifyChannel. + */ + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); + Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE); + } + if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) && (statePtr->interestMask & TCL_READABLE) && (statePtr->inQueueHead != NULL) @@ -8542,13 +8574,11 @@ ChannelTimerProc( statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc,chanPtr); - Tcl_Preserve(statePtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); - Tcl_Release(statePtr); } else { - statePtr->timer = NULL; UpdateInterest(chanPtr); } + Tcl_Release(statePtr); } /* diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index cebc33f..23049fb 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -114,15 +114,15 @@ typedef struct { int dead; /* Boolean signal that some operations * should no longer be attempted. */ - Tcl_TimerToken readTimer; /* + Tcl_TimerToken readTimer; /* A token for the timer that is scheduled in order to call Tcl_NotifyChannel when the - channel is readable + channel is readable */ - Tcl_TimerToken writeTimer; /* + Tcl_TimerToken writeTimer; /* A token for the timer that is scheduled in order to call Tcl_NotifyChannel when the - channel is writable + channel is writable */ /* diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 106b4e9..3870f3d 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1028,6 +1028,12 @@ declare 257 { void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } + +# TIP 431: temporary directory creation function +declare 258 { + Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj) +} ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index 3db1264..a2d19f9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2967,6 +2967,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); @@ -3105,6 +3106,7 @@ MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); +MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); @@ -4544,7 +4546,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (bignum).alloc = (bignumPayload >> 15) & 0x7fff; \ (bignum).used = bignumPayload & 0x7fff; \ } \ - } while (0) + } while (0) /* *---------------------------------------------------------------- diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index eddbcb3..56abe77 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -653,6 +653,9 @@ EXTERN void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); +/* 258 */ +EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj); typedef struct TclIntStubs { int magic; @@ -916,6 +919,7 @@ typedef struct TclIntStubs { int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ + Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -1359,6 +1363,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticPackage \ (tclIntStubsPtr->tclStaticPackage) /* 257 */ +#define TclpCreateTemporaryDirectory \ + (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclLink.c b/generic/tclLink.c index 8096c25..030e471 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -27,6 +27,7 @@ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + Namespace *nsPtr; /* Namespace containing Tcl variable */ Tcl_Obj *varName; /* Name of variable (must be global). This is * needed during trace callbacks, since the * actual variable may be aliased at that time @@ -158,6 +159,8 @@ Tcl_LinkVar( { Tcl_Obj *objPtr; Link *linkPtr; + Namespace *dummy; + const char *name; int code; linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, @@ -170,6 +173,7 @@ Tcl_LinkVar( linkPtr = ckalloc(sizeof(Link)); linkPtr->interp = interp; + linkPtr->nsPtr = NULL; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; @@ -196,6 +200,11 @@ Tcl_LinkVar( LinkFree(linkPtr); return TCL_ERROR; } + + TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, + &(linkPtr->nsPtr), &dummy, &dummy, &name); + linkPtr->nsPtr->refCount++; + code = Tcl_TraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); @@ -240,6 +249,8 @@ Tcl_LinkArray( { Tcl_Obj *objPtr; Link *linkPtr; + Namespace *dummy; + const char *name; int code; if (size < 1) { @@ -362,6 +373,11 @@ Tcl_LinkArray( linkPtr->interp = interp; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); + + TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, + &(linkPtr->nsPtr), &dummy, &dummy, &name); + linkPtr->nsPtr->refCount++; + objPtr = ObjValue(linkPtr); if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { @@ -376,8 +392,6 @@ Tcl_LinkArray( if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); LinkFree(linkPtr); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj((int) linkPtr->addr)); } return code; } @@ -747,7 +761,7 @@ LinkTraceProc( */ if (flags & TCL_TRACE_UNSETS) { - if (Tcl_InterpDeleted(interp)) { + if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) { Tcl_DecrRefCount(linkPtr->varName); LinkFree(linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { @@ -1497,6 +1511,9 @@ static void LinkFree( Link *linkPtr) /* Structure describing linked variable. */ { + if (linkPtr->nsPtr) { + TclNsDecrRefCount(linkPtr->nsPtr); + } if (linkPtr->flags & LINK_ALLOC_ADDR) { ckfree(linkPtr->addr); } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index b553880..bbe357d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1086,6 +1086,13 @@ Tcl_DeleteNamespace( } TclNsDecrRefCount(nsPtr); } + +int +TclNamespaceDeleted( + Namespace *nsPtr) +{ + return (nsPtr->flags & NS_DYING) ? 1 : 0; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclOO.c b/generic/tclOO.c index 0440395..e9cc0f0 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -346,14 +346,14 @@ InitFoundation( */ Tcl_DStringInit(&buffer); - for (i=0 ; defineCmds[i].name ; i++) { + for (i = 0 ; defineCmds[i].name ; i++) { TclDStringAppendLiteral(&buffer, "::oo::define::"); Tcl_DStringAppend(&buffer, defineCmds[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL); Tcl_DStringFree(&buffer); } - for (i=0 ; objdefCmds[i].name ; i++) { + for (i = 0 ; objdefCmds[i].name ; i++) { TclDStringAppendLiteral(&buffer, "::oo::objdefine::"); Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), @@ -373,10 +373,10 @@ InitFoundation( * Basic method declarations for the core classes. */ - for (i=0 ; objMethods[i].name ; i++) { + for (i = 0 ; objMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); } - for (i=0 ; clsMethods[i].name ; i++) { + for (i = 0 ; clsMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); } @@ -388,7 +388,7 @@ InitFoundation( TclNewLiteralStringObj(namePtr, "new"); Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, - namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL); + namePtr /* keeps ref */, 0 /* private */, NULL, NULL); fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); @@ -667,10 +667,8 @@ AllocObject( Tcl_ResetResult(interp); } - configNamespace: - - ((Namespace *)oPtr->namespacePtr)->refCount++; + ((Namespace *) oPtr->namespacePtr)->refCount++; /* * Make the namespace know about the helper commands. This grants access @@ -874,10 +872,14 @@ TclOODeleteDescendants( if (clsPtr->mixinSubs.num > 0) { while (clsPtr->mixinSubs.num > 0) { - mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1]; - /* This condition also covers the case where mixinSubclassPtr == + mixinSubclassPtr = + clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1]; + + /* + * This condition also covers the case where mixinSubclassPtr == * clsPtr */ + if (!Deleted(mixinSubclassPtr->thisPtr) && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, @@ -897,7 +899,7 @@ TclOODeleteDescendants( if (clsPtr->subclasses.num > 0) { while (clsPtr->subclasses.num > 0) { - subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1]; + subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1]; if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr) && !(subclassPtr->thisPtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, @@ -918,7 +920,8 @@ TclOODeleteDescendants( if (clsPtr->instances.num > 0) { while (clsPtr->instances.num > 0) { - instancePtr = clsPtr->instances.list[clsPtr->instances.num-1]; + instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1]; + /* * This condition also covers the case where instancePtr == oPtr */ @@ -1119,8 +1122,8 @@ ObjectNamespaceDeleted( if (Deleted(oPtr)) { /* - * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this - * guard could be removed. + * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, + * this guard could be removed. */ return; @@ -1134,7 +1137,10 @@ ObjectNamespaceDeleted( oPtr->flags |= OBJECT_DELETED; - /* Let the dominoes fall */ + /* + * Let the dominoes fall! + */ + if (oPtr->classPtr) { TclOODeleteDescendants(interp, oPtr); } @@ -1150,8 +1156,8 @@ ObjectNamespaceDeleted( CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); int result; - Tcl_InterpState state; + oPtr->flags |= DESTRUCTOR_CALLED; if (contextPtr != NULL) { @@ -1170,12 +1176,12 @@ ObjectNamespaceDeleted( /* * Instruct everyone to no longer use any allocated fields of the object. - * Also delete the command that refers to the object at this point (if - * it still exists) because otherwise its pointer to the object - * points into freed memory. + * Also delete the command that refers to the object at this point (if it + * still exists) because otherwise its pointer to the object points into + * freed memory. */ - if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) { + if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) { /* * Something has already started the command deletion process. We can * go ahead and clean up the the namespace, @@ -1201,10 +1207,7 @@ ObjectNamespaceDeleted( * methods on the object. */ - /* - * TODO: Should this be protected with a * !IsRoot() condition? - */ - + /* TODO: Should this be protected with a !IsRoot() condition? */ TclOORemoveFromInstances(oPtr, oPtr->selfCls); if (oPtr->mixins.num > 0) { @@ -1765,7 +1768,6 @@ TclNRNewObjectInstance( TclPushTailcallPoint(interp); return TclOOInvokeContext(contextPtr, interp, objc, objv); } - Object * TclNewObjectInstanceCommon( @@ -1780,7 +1782,6 @@ TclNewObjectInstanceCommon( const char *simpleName = NULL; Namespace *nsPtr = NULL, *dummy; Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - int isNew; if (nameStr) { TclGetNamespaceForQualName(interp, nameStr, inNsPtr, @@ -1790,21 +1791,14 @@ TclNewObjectInstanceCommon( * Disallow creation of an object over an existing command. */ - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew); - if (!isNew) { + hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName); + if (hPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create object \"%s\": command already exists with" " that name", nameStr)); Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); return NULL; } - - /* - * We could make a hash entry! Don't actually want to do that here so - * nuke it immediately because we'll create it properly soon. - */ - - Tcl_DeleteHashEntry(hPtr); } /* @@ -1837,8 +1831,6 @@ TclNewObjectInstanceCommon( return oPtr; } - - static int FinalizeAlloc( ClientData data[], @@ -1974,7 +1966,11 @@ Tcl_CopyObjectInstance( if (mixinPtr && mixinPtr != o2Ptr->selfCls) { TclOOAddToInstances(o2Ptr, mixinPtr); } - /* For the reference just created in DUPLICATE */ + + /* + * For the reference just created in DUPLICATE. + */ + AddRef(mixinPtr->thisPtr); } @@ -2012,6 +2008,7 @@ Tcl_CopyObjectInstance( o2Ptr->flags = oPtr->flags & ~( OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); + /* * Copy the object's metadata. */ @@ -2075,9 +2072,11 @@ Tcl_CopyObjectInstance( FOREACH(superPtr, cls2Ptr->superclasses) { TclOOAddToSubclasses(cls2Ptr, superPtr); - /* For the new item in cls2Ptr->superclasses that memcpy just - * created + /* + * For the new item in cls2Ptr->superclasses that memcpy just + * created. */ + AddRef(superPtr->thisPtr); } @@ -2121,7 +2120,11 @@ Tcl_CopyObjectInstance( DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { TclOOAddToMixinSubs(cls2Ptr, mixinPtr); - /* For the copy just created in DUPLICATE */ + + /* + * For the copy just created in DUPLICATE. + */ + AddRef(mixinPtr->thisPtr); } @@ -2783,7 +2786,7 @@ Tcl_ObjectContextInvokeNext( int savedSkip = contextPtr->skip; int result; - if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { /* * We're at the end of the chain; generate an error message unless the * interpreter is being torn down, in which case we might be getting @@ -2852,7 +2855,7 @@ TclNRObjectContextInvokeNext( { register CallContext *contextPtr = (CallContext *) context; - if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { /* * We're at the end of the chain; generate an error message unless the * interpreter is being torn down, in which case we might be getting diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index ace7fd7..c0d2e64 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -328,7 +328,7 @@ TclOOInvokeContext( if (contextPtr->index == 0) { int i; - for (i=0 ; i<contextPtr->callPtr->numChain ; i++) { + for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { AddRef(contextPtr->callPtr->chain[i].mPtr); } @@ -406,7 +406,7 @@ FinalizeMethodRefs( CallContext *contextPtr = data[0]; int i; - for (i=0 ; i<contextPtr->callPtr->numChain ; i++) { + for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr); } return result; @@ -641,7 +641,10 @@ SortMethodNames( return i; } -/* Comparator for SortMethodNames */ +/* + * Comparator for SortMethodNames + */ + static int CmpStr( const void *ptr1, @@ -1004,7 +1007,7 @@ AddMethodToCallChain( * any leading filters. */ - for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) { + for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) { if (callPtr->chain[i].mPtr == mPtr && callPtr->chain[i].isFilter == (doneFilters != NULL)) { /* @@ -1016,8 +1019,8 @@ AddMethodToCallChain( Class *declCls = callPtr->chain[i].filterDeclarer; - for (; i+1<callPtr->numChain ; i++) { - callPtr->chain[i] = callPtr->chain[i+1]; + for (; i + 1 < callPtr->numChain ; i++) { + callPtr->chain[i] = callPtr->chain[i + 1]; } callPtr->chain[i].mPtr = mPtr; callPtr->chain[i].isFilter = (doneFilters != NULL); @@ -1817,7 +1820,7 @@ TclOORenderCallChain( */ objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); - for (i=0 ; i<callPtr->numChain ; i++) { + for (i = 0 ; i < callPtr->numChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; descObjs[0] = diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 65d6ea1..6a00018 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -50,6 +50,12 @@ struct DeclaredSlot { resolver, NULL, NULL}} /* + * A [string match] pattern used to determine if a method should be exported. + */ + +#define PUBLIC_PATTERN "[a-z]*" + +/* * Forward declarations. */ @@ -278,7 +284,7 @@ TclOOObjectSetFilters( } else { filtersList = ckrealloc(oPtr->filters.list, size); } - for (i=0 ; i<numFilters ; i++) { + for (i = 0 ; i < numFilters ; i++) { filtersList[i] = filters[i]; Tcl_IncrRefCount(filters[i]); } @@ -337,7 +343,7 @@ TclOOClassSetFilters( } else { filtersList = ckrealloc(classPtr->filters.list, size); } - for (i=0 ; i<numFilters ; i++) { + for (i = 0 ; i < numFilters ; i++) { filtersList[i] = filters[i]; Tcl_IncrRefCount(filters[i]); } @@ -400,7 +406,11 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); - /* For the new copy created by memcpy */ + + /* + * For the new copy created by memcpy(). + */ + AddRef(mixinPtr->thisPtr); } } @@ -452,7 +462,11 @@ TclOOClassSetMixins( memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); - /* For the new copy created by memcpy */ + + /* + * For the new copy created by memcpy. + */ + AddRef(mixinPtr->thisPtr); } } @@ -724,15 +738,16 @@ TclOOUnknownDefinition( * Got one match, and only one match! */ - Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1)); + Tcl_Obj **newObjv = + TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1)); int result; newObjv[0] = Tcl_NewStringObj(matchedStr, -1); Tcl_IncrRefCount(newObjv[0]); if (objc > 2) { - memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2)); } - result = Tcl_EvalObjv(interp, objc-1, newObjv, 0); + result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); TclStackFree(interp, newObjv); return result; @@ -1039,17 +1054,20 @@ MagicDefinitionInvoke( obj2Ptr = Tcl_NewObj(); cmd = FindCommand(interp, objv[cmdIndex], nsPtr); if (cmd == NULL) { - /* punt this case! */ + /* + * Punt this case! + */ + Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]); } else { Tcl_GetCommandFullName(interp, cmd, obj2Ptr); } Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); /* TODO: overflow? */ - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset); + Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset); Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); - result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE); + result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE); if (isRoot) { TclResetRewriteEnsemble(interp, 1); } @@ -1685,7 +1703,7 @@ TclOODefineDeleteMethodObjCmd( return TCL_ERROR; } - for (i=1 ; i<objc ; i++) { + for (i = 1; i < objc; i++) { /* * Delete the method structure from the appropriate hash table. */ @@ -1811,7 +1829,7 @@ TclOODefineExportObjCmd( return TCL_ERROR; } - for (i=1 ; i<objc ; i++) { + for (i = 1; i < objc; i++) { /* * Exporting is done by adding the PUBLIC_METHOD flag to the method * record. If there is no such method in this object or class (i.e. @@ -1904,7 +1922,7 @@ TclOODefineForwardObjCmd( Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } - isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") + isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) ? PUBLIC_METHOD : 0; if (IsPrivateDefine(interp)) { isPublic = TRUE_PRIVATE_METHOD; @@ -1914,7 +1932,7 @@ TclOODefineForwardObjCmd( * Create the method structure. */ - prefixObj = Tcl_NewListObj(objc-2, objv+2); + prefixObj = Tcl_NewListObj(objc - 2, objv + 2); if (isInstanceForward) { mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1], prefixObj); @@ -2002,7 +2020,7 @@ TclOODefineMethodObjCmd( if (IsPrivateDefine(interp)) { isPublic = TRUE_PRIVATE_METHOD; } else { - isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") + isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) ? PUBLIC_METHOD : 0; } } @@ -2124,7 +2142,7 @@ TclOODefineUnexportObjCmd( return TCL_ERROR; } - for (i=1 ; i<objc ; i++) { + for (i = 1; i < objc; i++) { /* * Unexporting is done by removing the PUBLIC_METHOD flag from the * method record. If there is no such method in this object or class @@ -2340,7 +2358,7 @@ ClassFilterSet( int filterc; Tcl_Obj **filterv; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2424,7 +2442,7 @@ ClassMixinSet( Tcl_Obj **mixinv; Class **mixins; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; @@ -2445,7 +2463,7 @@ ClassMixinSet( mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); - for (i=0 ; i<mixinc ; i++) { + for (i = 0; i < mixinc; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { @@ -2529,7 +2547,7 @@ ClassSuperSet( Tcl_Obj **superv; Class **superclasses, *superPtr; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "superclassList"); return TCL_ERROR; @@ -2576,14 +2594,14 @@ ClassSuperSet( superc = 1; AddRef(superclasses[0]->thisPtr); } else { - for (i=0 ; i<superc ; i++) { + for (i = 0; i < superc; i++) { superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); if (superclasses[i] == NULL) { i--; goto failedAfterAlloc; } - for (j=0 ; j<i ; j++) { + for (j = 0; j < i; j++) { if (superclasses[j] == superclasses[i]) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "class should only be a direct superclass once", @@ -2705,7 +2723,7 @@ ClassVarsSet( Tcl_Obj **varv; int i; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2724,7 +2742,7 @@ ClassVarsSet( return TCL_ERROR; } - for (i=0 ; i<varc ; i++) { + for (i = 0; i < varc; i++) { const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { @@ -2803,7 +2821,7 @@ ObjFilterSet( int filterc; Tcl_Obj **filterv; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2877,7 +2895,7 @@ ObjMixinSet( Class **mixins; int i; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; @@ -2892,7 +2910,7 @@ ObjMixinSet( mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); - for (i=0 ; i<mixinc ; i++) { + for (i = 0; i < mixinc; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { @@ -2967,7 +2985,7 @@ ObjVarsSet( int varc, i; Tcl_Obj **varv; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "variableList"); return TCL_ERROR; @@ -2980,7 +2998,7 @@ ObjVarsSet( return TCL_ERROR; } - for (i=0 ; i<varc ; i++) { + for (i = 0; i < varc; i++) { const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { diff --git a/generic/tclResult.c b/generic/tclResult.c index 5a03421..4d14f01 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -464,7 +464,6 @@ Tcl_SetResult( ResetObjResult(iPtr); } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -488,9 +487,6 @@ Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { Interp *iPtr = (Interp *) interp; -#ifdef TCL_NO_DEPRECATED - return Tcl_GetString(iPtr->objResultPtr); -#else /* * If the string result is empty, move the object result to the string * result, then reset the object result. @@ -501,8 +497,8 @@ Tcl_GetStringResult( TCL_VOLATILE); } return iPtr->result; -#endif } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index e7cb2c5..c9abb1a 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1849,15 +1849,15 @@ RefineApproximation( */ msb = binExponent + M2; /* 1008 */ - nDigits = msb / DIGIT_BIT + 1; + nDigits = msb / MP_DIGIT_BIT + 1; mp_init_size(&twoMv, nDigits); - i = (msb % DIGIT_BIT + 1); + i = (msb % MP_DIGIT_BIT + 1); twoMv.used = nDigits; significand *= SafeLdExp(1.0, i); while (--nDigits >= 0) { twoMv.dp[nDigits] = (mp_digit) significand; significand -= (mp_digit) significand; - significand = SafeLdExp(significand, DIGIT_BIT); + significand = SafeLdExp(significand, MP_DIGIT_BIT); } for (i = 0; i <= 8; ++i) { if (M5 & (1 << i)) { @@ -3145,7 +3145,7 @@ ShouldBankerRoundUpPowD( int isodd) /* 1 if the digit is odd, 0 if even. */ { int i; - static const mp_digit topbit = ((mp_digit)1) << (DIGIT_BIT - 1); + static const mp_digit topbit = ((mp_digit)1) << (MP_DIGIT_BIT - 1); if (b->used < sd || (b->dp[sd-1] & topbit) == 0) { return 0; @@ -4214,8 +4214,8 @@ TclDoubleDigits( * in the denominator' case. */ - if (s2 % DIGIT_BIT != 0) { - int delta = DIGIT_BIT - (s2 % DIGIT_BIT); + if (s2 % MP_DIGIT_BIT != 0) { + int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT); b2 += delta; m2plus += delta; @@ -4223,7 +4223,7 @@ TclDoubleDigits( s2 += delta; } return ShorteningBignumConversionPowD(&d, bw, b2, b5, - m2plus, m2minus, m5, s2/DIGIT_BIT, k, len, ilim, ilim1, + m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* @@ -4270,14 +4270,14 @@ TclDoubleDigits( * in the denominator' case. */ - if (s2 % DIGIT_BIT != 0) { - int delta = DIGIT_BIT - (s2 % DIGIT_BIT); + if (s2 % MP_DIGIT_BIT != 0) { + int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT); b2 += delta; s2 += delta; } return StrictBignumConversionPowD(&d, bw, b2, b5, - s2/DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); + s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* * There are no helpful special cases, but at least we know in @@ -4402,7 +4402,7 @@ TclInitDoubleConversion(void) + 0.5 * log(10.)) / log(10.)); minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG) * log((double) FLT_RADIX) / log(10.)); - log10_DIGIT_MAX = (int) floor(DIGIT_BIT * log(2.) / log(10.)); + log10_DIGIT_MAX = (int) floor(MP_DIGIT_BIT * log(2.) / log(10.)); /* * Nokia 770's software-emulated floating point is "middle endian": the @@ -4606,7 +4606,7 @@ TclBignumToDouble( r = 0.0; for (i=b.used-1 ; i>=0 ; --i) { - r = ldexp(r, DIGIT_BIT) + b.dp[i]; + r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; } mp_clear(&b); @@ -4675,7 +4675,7 @@ TclCeil( mp_add_d(&b, 1, &b); } for (i=b.used-1 ; i>=0 ; --i) { - r = ldexp(r, DIGIT_BIT) + b.dp[i]; + r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; } r = ldexp(r, bits - mantBits); } @@ -4725,7 +4725,7 @@ TclFloor( mp_copy(a, &b); } for (i=b.used-1 ; i>=0 ; --i) { - r = ldexp(r, DIGIT_BIT) + b.dp[i]; + r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; } r = ldexp(r, bits - mantBits); } @@ -4787,7 +4787,7 @@ BignumToBiasedFrExp( r = 0.0; for (i=b.used-1; i>=0; --i) { - r = ldexp(r, DIGIT_BIT) + b.dp[i]; + r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; } mp_clear(&b); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 6652f15..547ece1 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2270,11 +2270,11 @@ Tcl_AppendFormatToObj( } #endif } else if (useBig && big.used) { - int leftover = (big.used * DIGIT_BIT) % numBits; - mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover); + int leftover = (big.used * MP_DIGIT_BIT) % numBits; + mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover); numDigits = 1 + - (((Tcl_WideInt) big.used * DIGIT_BIT) / numBits); + (((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits); while ((mask & big.dp[big.used-1]) == 0) { numDigits--; mask >>= numBits; @@ -2310,9 +2310,9 @@ Tcl_AppendFormatToObj( if (useBig && big.used) { if (index < big.used && (size_t) shift < - CHAR_BIT*sizeof(Tcl_WideUInt) - DIGIT_BIT) { + CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) { bits |= ((Tcl_WideUInt) big.dp[index++]) << shift; - shift += DIGIT_BIT; + shift += MP_DIGIT_BIT; } shift -= numBits; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2eb2259..c9a195f 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -368,6 +368,8 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig # define Tcl_Eval 0 # undef Tcl_GlobalEval # define Tcl_GlobalEval 0 +# undef Tcl_GetStringResult +# define Tcl_GetStringResult 0 # undef Tcl_SaveResult # define Tcl_SaveResult 0 # undef Tcl_RestoreResult @@ -749,6 +751,7 @@ static const TclIntStubs tclIntStubs = { TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ TclStaticPackage, /* 257 */ + TclpCreateTemporaryDirectory, /* 258 */ }; static const TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclTest.c b/generic/tclTest.c index f301ebc..8474a91 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -971,8 +971,10 @@ AsyncHandlerProc( Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; - asyncPtr = asyncPtr->nextPtr) { - if (asyncPtr->id == id) break; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + break; + } } Tcl_MutexUnlock(&asyncTestMutex); @@ -3325,10 +3327,7 @@ TestlinkarrayCmd( }; int optionIndex, typeIndex, readonly, i, size, length; char *name, *arg; - long addr; /* Wrong on Windows, but that's MS's fault for - * not supporting <stdint.h> correctly. They - * can suffer the warnings; the rest of us - * shouldn't have to! */ + Tcl_WideInt addr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option args"); @@ -3386,7 +3385,7 @@ TestlinkarrayCmd( */ if (i < objc) { - if (Tcl_GetLongFromObj(interp, objv[i], &addr) == TCL_ERROR) { + if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "wrong address value", -1)); return TCL_ERROR; @@ -3394,7 +3393,7 @@ TestlinkarrayCmd( } else { addr = 0; } - return Tcl_LinkArray(interp, name, (void *) addr, + return Tcl_LinkArray(interp, name, INT2PTR(addr), LinkTypes[typeIndex] | readonly, size); } return TCL_OK; @@ -4418,7 +4417,7 @@ TesttranslatefilenameCmd( * * TestupvarCmd -- * - * This procedure implements the "testupvar2" command. It is used + * This procedure implements the "testupvar" command. It is used * to test Tcl_UpVar and Tcl_UpVar2. * * Results: diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 15c87b5..ea80320 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -310,8 +310,8 @@ TclCreateAbsoluteTimerHandler( timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId); /* - * Add the event to the queue in the correct position - * (ordered by event firing time). + * Add the event to the queue in the correct position (ordered by event + * firing time). */ for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; @@ -1013,8 +1013,8 @@ AfterDelay( Tcl_GetTime(&now); endTime = now; - endTime.sec += (long)(ms/1000); - endTime.usec += ((int)(ms%1000))*1000; + endTime.sec += (long)(ms / 1000); + endTime.usec += ((int)(ms % 1000)) * 1000; if (endTime.usec >= 1000000) { endTime.sec++; endTime.usec -= 1000000; @@ -1042,17 +1042,17 @@ AfterDelay( if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } - if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { - diff = 1; - } + if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { + diff = 1; + } if (diff > 0) { - Tcl_Sleep((int) diff); - if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { - break; - } + Tcl_Sleep((long) diff); + if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { + break; + } } else { - break; - } + break; + } } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); if (diff > TCL_TIME_MAXIMUM_SLICE) { diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h index 26eef26..cc9f286 100644 --- a/generic/tclTomMath.h +++ b/generic/tclTomMath.h @@ -1,14 +1,6 @@ -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + #ifndef BN_H_ #define BN_H_ @@ -115,29 +107,30 @@ typedef unsigned long long mp_word; #define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1)) #define MP_DIGIT_MAX MP_MASK -/* equalities */ +typedef int mp_sign; +#define MP_ZPOS 0 /* positive integer */ +#define MP_NEG 1 /* negative */ +typedef int mp_ord; #define MP_LT -1 /* less than */ #define MP_EQ 0 /* equal to */ #define MP_GT 1 /* greater than */ - -#define MP_ZPOS 0 /* positive integer */ -#define MP_NEG 1 /* negative */ - +typedef int mp_bool; +#define MP_YES 1 /* yes response */ +#define MP_NO 0 /* no response */ +typedef int mp_err; #define MP_OKAY 0 /* ok result */ +#define MP_ERR -1 /* unknown error */ #define MP_MEM -2 /* out of mem */ #define MP_VAL -3 /* invalid input */ #define MP_RANGE MP_VAL #define MP_ITER -4 /* Max. iterations reached */ -#define MP_YES 1 /* yes response */ -#define MP_NO 0 /* no response */ - /* Primality generation flags */ #define LTM_PRIME_BBS 0x0001 /* BBS style prime */ #define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ #define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ -typedef int mp_err; +/* tunable cutoffs */ /* define this to use lower memory usage routines (exptmods mostly) */ /* #define MP_LOW_MEM */ @@ -146,6 +139,8 @@ typedef int mp_err; #ifndef MP_PREC # ifndef MP_LOW_MEM # define MP_PREC 32 /* default digits of precision */ +# elif defined(MP_8BIT) +# define MP_PREC 16 /* default digits of precision */ # else # define MP_PREC 8 /* default digits of precision */ # endif @@ -154,6 +149,45 @@ typedef int mp_err; /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ #define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1)) +/* + * MP_WUR - warn unused result + * --------------------------- + * + * The result of functions annotated with MP_WUR must be + * checked and cannot be ignored. + * + * Most functions in libtommath return an error code. + * This error code must be checked in order to prevent crashes or invalid + * results. + * + * If you still want to avoid the error checks for quick and dirty programs + * without robustness guarantees, you can `#define MP_WUR` before including + * tommath.h, disabling the warnings. + */ +#ifndef MP_WUR +# if defined(__GNUC__) && __GNUC__ >= 4 +# define MP_WUR __attribute__((warn_unused_result)) +# else +# define MP_WUR +# endif +#endif + +#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 301) +# define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x))) +# define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s) +# define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s) +#elif defined(_MSC_VER) && _MSC_VER >= 1500 +# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x)) +# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s)) +#else +# define MP_DEPRECATED +# define MP_DEPRECATED_PRAGMA(s) +#endif + +#define USED(m) ((m)->used) +#define DIGIT(m,k) ((m)->dp[(k)]) +#define SIGN(m) ((m)->sign) + /* the infamous mp_int structure */ #ifndef MP_INT_DECLARED #define MP_INT_DECLARED @@ -168,10 +202,6 @@ struct mp_int { typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); -#define USED(m) ((m)->used) -#define DIGIT(m, k) ((m)->dp[(k)]) -#define SIGN(m) ((m)->sign) - /* error code to char* string */ const char *mp_error_to_string(int code); diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 165e3b7..c5ed4d5 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -45,8 +45,11 @@ /* Rename the global symbols in libtommath to avoid linkage conflicts */ #define bn_reverse TclBN_reverse +#define s_mp_reverse TclBN_reverse #define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs +#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs #define fast_s_mp_sqr TclBN_fast_s_mp_sqr +#define s_mp_sqr_fast TclBN_fast_s_mp_sqr #define mp_add TclBN_mp_add #define mp_add_d TclBN_mp_add_d #define mp_and TclBN_mp_and @@ -79,7 +82,9 @@ #define mp_init_set_int TclBN_mp_init_set_int #define mp_init_size TclBN_mp_init_size #define mp_karatsuba_mul TclBN_mp_karatsuba_mul +#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul #define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr +#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr #define mp_lshd TclBN_mp_lshd #define mp_mod TclBN_mp_mod #define mp_mod_2d TclBN_mp_mod_2d @@ -108,7 +113,9 @@ #define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin #define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n #define mp_toom_mul TclBN_mp_toom_mul +#define s_mp_toom_mul TclBN_mp_toom_mul #define mp_toom_sqr TclBN_mp_toom_sqr +#define s_mp_toom_sqr TclBN_mp_toom_sqr #define mp_toradix_n TclBN_mp_toradix_n #define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size #define mp_xor TclBN_mp_xor diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index c3887f0..3d1941c 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -381,6 +381,7 @@ static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +static void ZipfsExitHandler(ClientData clientData); static void ZipfsSetup(void); static int ZipChannelClose(void *instanceData, Tcl_Interp *interp); @@ -1286,6 +1287,7 @@ ZipFSCatalogFilesystem( *zf = *zf0; zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf); zf->mountPointLen = strlen(zf->mountPoint); zf->nameLength = strlen(zipname); zf->name = ckalloc(zf->nameLength + 1); @@ -1679,9 +1681,16 @@ TclZipfs_Mount( return TCL_ERROR; } if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { + ckfree(zf); return TCL_ERROR; } - return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname); + if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) + != TCL_OK) { + ckfree(zf); + return TCL_ERROR; + } + ckfree(zf); + return TCL_OK; } /* @@ -1844,6 +1853,7 @@ TclZipfs_Unmount( ckfree(z); } ZipFSCloseArchive(interp, zf); + Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf); ckfree(zf); unmounted = 1; done: @@ -4837,6 +4847,17 @@ ZipfsAppHookFindTclInit( return TCL_ERROR; } +static void +ZipfsExitHandler( + ClientData clientData) +{ + ZipFile *zf = (ZipFile *)clientData; + + if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) { + Tcl_Panic("tried to unmount busy filesystem"); + } +} + /* *------------------------------------------------------------------------- * diff --git a/library/msgs/ja.msg b/library/msgs/ja.msg index 76b5fa4..dac690b 100644 --- a/library/msgs/ja.msg +++ b/library/msgs/ja.msg @@ -40,5 +40,5 @@ namespace eval ::tcl::clock { ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日" ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒" ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z" - ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988}" + ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988} {1556668800 令和 2018}" } diff --git a/tests-perf/test-performance.tcl b/tests-perf/test-performance.tcl index 418c999..78189e6 100644 --- a/tests-perf/test-performance.tcl +++ b/tests-perf/test-performance.tcl @@ -51,13 +51,13 @@ proc _test_out_total {} { set mintm 0x7fffffff set maxtm 0 - set nett 0 + set nettm 0 set wtm 0 set wcnt 0 set i 0 foreach tm $_(itm) { if {[llength $tm] > 6} { - set nett [expr {$nett + [lindex $tm 6]}] + set nettm [expr {$nettm + [lindex $tm 6]}] } set wtm [expr {$wtm + [lindex $tm 0]}] set wcnt [expr {$wcnt + [lindex $tm 2]}] @@ -69,15 +69,15 @@ proc _test_out_total {} { puts [string repeat ** 40] set s [format "%d cases in %.2f sec." $tcnt [expr {([clock milliseconds] - $_(starttime)) / 1000.0}]] - if {$nett > 0} { - append s [format " (%.2f nett-sec.)" [expr {$nett / 1000.0}]] + if {$nettm > 0} { + append s [format " (%.2f net-sec.)" [expr {$nettm / 1000.0}]] } puts "Total $s:" lset _(m) 0 [format %.6f $wtm] lset _(m) 2 $wcnt - lset _(m) 4 [format %.3f [expr {$wcnt / (($nett ? $nett : ($tcnt * [lindex $_(reptime) 0])) / 1000.0)}]] + lset _(m) 4 [format %.3f [expr {$wcnt / (($nettm ? $nettm : ($tcnt * [lindex $_(reptime) 0])) / 1000.0)}]] if {[llength $_(m)] > 6} { - lset _(m) 6 [format %.3f $nett] + lset _(m) 6 [format %.3f $nettm] } puts $_(m) puts "Average:" diff --git a/tests/basic.test b/tests/basic.test index 1890042..4561667 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -964,6 +964,18 @@ test basic-48.24.$noComp {expansion: empty not canonical list, regression test, run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]} } -result [lrepeat 3 {}] -cleanup {unset -nocomplain a} +test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -setup { + unset -nocomplain ::CRLF + set ::CRLF "\r\n" +} -body { + # Force variant that turned up in Bug 2c154a40be as that's externally + # noticeable in an important downstream project. + run {scan [list {*}$::CRLF]x %c%c%c} +} -cleanup { + unset -nocomplain ::CRLF +} -result {120 {} {}} + + } ;# End of noComp loop test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { diff --git a/tests/clock.test b/tests/clock.test index b17c543..8d73bf2 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -36707,16 +36707,18 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{ } -body { set trouble {} - foreach {date jdate} [list \ - 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 \ - 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 \ - 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 \ - 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 \ - 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 \ - 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 \ - 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 \ - 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 \ - ] { + foreach {date jdate} { + 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 + 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 + 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 + 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 + 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 + 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 + 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 + 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 + 2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5 + 2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5 + } { set status [catch { set secs [clock scan $date \ -timezone +0900 \ diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 88c0367..f8ab361 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -235,7 +235,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -1526,7 +1526,7 @@ test cmdAH-29.6.1 { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} @@ -1658,6 +1658,62 @@ test cmdAH-32.6 {file tempfile - templates} -body { } -constraints {unix nonPortable} -cleanup { catch {file delete $name} } -result ok + +test cmdAH-33.1 {file tempdir} -body { + file tempdir a b +} -returnCodes error -result {wrong # args: should be "file tempdir ?template?"} +test cmdAH-33.2 {file tempdir} -body { + set d [file tempdir] + list [file tail $d] [file exists $d] [file type $d] \ + [glob -nocomplain -directory $d *] +} -match glob -result {tcl_* 1 directory {}} -cleanup { + catch {file delete $d} +} +test cmdAH-33.3 {file tempdir} -body { + set d [file tempdir gorp] + list [file tail $d] [file exists $d] [file type $d] \ + [glob -nocomplain -directory $d *] +} -match glob -result {gorp_* 1 directory {}} -cleanup { + catch {file delete $d} +} +test cmdAH-33.4 {file tempdir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -body { + set pre [glob -nocomplain -directory $base *] + set d [file normalize [file tempdir $base/]] + list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ + $pre [glob -nocomplain -directory $d *] +} -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup { + catch {file delete -force $base} +} +test cmdAH-33.5 {file tempdir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -body { + set pre [glob -nocomplain -directory $base *] + set d [file normalize [file tempdir $base/gorp]] + list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ + $pre [glob -nocomplain -directory $d *] +} -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup { + catch {file delete -force $base} +} +test cmdAH-33.6 {file tempdir: missing parent dir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -returnCodes error -body { + file tempdir $base/quux/ +} -cleanup { + catch {file delete -force $base} +} -result {can't create temporary directory: no such file or directory} +test cmdAH-33.7 {file tempdir: missing parent dir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -returnCodes error -body { + file tempdir $base/quux/foobar +} -cleanup { + catch {file delete -force $base} +} -result {can't create temporary directory: no such file or directory} # This shouldn't work, but just in case a test above failed... catch {close $newFileId} diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 1ad45e7..60b104f 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -316,7 +316,7 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { # The tests for Tcl_SubstObjCmd are in subst.test # The tests for Tcl_SwitchObjCmd are in switch.test -# todo: rewrite this if monotonic clock is provided resp. command "after" +# todo: rewrite this if monotonic clock is provided resp. command "after" # gets microsecond accuracy (RFE [fdfbd5e10] gets merged): proc _nrt_sleep {msec} { set usec [expr {$msec * 1000}] @@ -369,10 +369,10 @@ test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg } {1 {missing close-brace}} test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} { - regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? nett-ms$} [timerate {} 0] + regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0] } 1 test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} { - regexp {^0 \ws/# 0 # 0 #/sec 0 nett-ms$} [timerate {} 0 0] + regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0] } 1 test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} { set m1 [timerate {_nrt_sleep 0} 20] @@ -403,6 +403,14 @@ test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} { [expr {[lindex $m1 4] > 1000}] \ [expr {[lindex $m1 6] < 10}] } {1 1 1 1} +test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} { + set m1 [timerate {continue; return -code error "unexpected"} 1000 10] + list \ + [expr {[lindex $m1 0] < 1000}] \ + [expr {[lindex $m1 2] == 10}] \ + [expr {[lindex $m1 4] > 1000}] \ + [expr {[lindex $m1 6] < 100}] +} {1 1 1 1} test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} { set m1 [timerate {} 1000 5]; # max-count wins set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins @@ -416,6 +424,12 @@ test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} { [expr {[lindex $m1 4] == 1000000}] \ [expr {[lindex $m1 6] <= 0.001}] } {1 1 1 1} +test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} { + set m1 {set m2 ok} + if 1 $m1 + timerate $m1 1000 10 + if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop +} ok test cmdMZ-try-1.0 { diff --git a/tests/coroutine.test b/tests/coroutine.test index fe46c8b..86a5481 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -937,6 +937,81 @@ test coroutine-10.9 {coroinject: advanced features} -setup { } -cleanup { interp delete $i } -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}} + +test coroutine-11.1 {coro type} { + coroutine demo eval { + yield + yield "PHASE 1" + yieldto string cat "PHASE 2" + ::tcl::unsupported::corotype [info coroutine] + } + list [demo] [::tcl::unsupported::corotype demo] \ + [demo] [::tcl::unsupported::corotype demo] [demo] +} {{PHASE 1} yield {PHASE 2} yieldto active} +test coroutine-11.2 {coro type} -setup { + catch {rename nosuchcommand ""} +} -returnCodes error -body { + ::tcl::unsupported::corotype nosuchcommand +} -result {can only get coroutine type of a coroutine} +test coroutine-11.3 {coro type} -returnCodes error -body { + proc notacoroutine {} {} + ::tcl::unsupported::corotype notacoroutine +} -returnCodes error -cleanup { + rename notacoroutine {} +} -result {can only get coroutine type of a coroutine} + +test coroutine-12.1 {coroutine general introspection} -setup { + set i [interp create] +} -body { + $i eval { + # Make the introspection code + namespace path tcl::unsupported + proc probe {type var} { + upvar 1 $var v + set f [info frame] + incr f -1 + set result [list $v [dict get [info frame $f] proc]] + if {$type eq "yield"} { + tailcall yield $result + } else { + tailcall yieldto string cat $result + } + } + proc pokecoro {c var} { + inject $c probe [corotype $c] $var + $c + } + + # Coroutine implementations + proc cbody1 {} { + set val [info coroutine] + set accum {} + while {[set val [yield $val]] ne ""} { + lappend accum $val + set val ok + } + return $accum + } + proc cbody2 {} { + set val [info coroutine] + set accum {} + while {[llength [set val [yieldto string cat $val]]]} { + lappend accum {*}$val + set val ok + } + return $accum + } + + # Make the coroutines + coroutine c1 cbody1 + coroutine c2 cbody2 + list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \ + [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \ + [c1] [c2] + } +} -cleanup { + interp delete $i +} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}} # cleanup unset lambda diff --git a/tests/dict.test b/tests/dict.test index 62590e7..e5284fc 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2128,7 +2128,7 @@ test dict-27.8 {dict getwithdefault command} -returnCodes error -body { test dict-27.9 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {} {} } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -test dict-26.10 {dict getdef command} -returnCodes error -body { +test dict-27.10 {dict getdef command} -returnCodes error -body { dict getwithdefault {a b c} d e } -result {missing value to go with key} test dict-27.11 {dict getwithdefault command} -body { @@ -2149,7 +2149,7 @@ test dict-27.15 {dict getwithdefault command} -body { test dict-27.16 {dict getwithdefault command} -returnCodes error -body { $dict getwithdefault {a {b c d}} a b d } -result {missing value to go with key} -test dict-26.17 {dict getdef command} -returnCodes error -body { +test dict-27.17 {dict getdef command} -returnCodes error -body { $dict getwithdefault {a b c} d e } -result {missing value to go with key} diff --git a/tests/interp.test b/tests/interp.test index 29e3b2d..76ac01f 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -20,7 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} foreach i [interp slaves] { interp delete $i diff --git a/tests/io.test b/tests/io.test index d42f59e..6470282 100644 --- a/tests/io.test +++ b/tests/io.test @@ -5963,6 +5963,69 @@ test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fi } {initial foo eof} close $f + +test chan-io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup { +} -constraints {stdio unixExecs fileevent openpipe} -body { + + namespace eval refchan { + namespace ensemble create + namespace export * + + + proc finalize {chan args} { + namespace delete c_$chan + } + + proc initialize {chan args} { + namespace eval c_$chan {} + namespace upvar c_$chan watching watching + set watching {} + list finalize initialize seek watch write + } + + + proc watch {chan args} { + namespace upvar c_$chan watching watching + foreach arg $args { + switch $arg { + write { + if {$arg ni $watching} { + lappend watching $arg + } + chan postevent $chan $arg + } + } + } + } + + + proc write {chan args} { + chan postevent $chan write + return 1 + } + } + set f [chan create w [namespace which refchan]] + chan configure $f -blocking 0 + set data "some data" + set x 0 + chan event $f writable [namespace code { + puts $f $data + incr count [string length $data] + if {$count > 262144} { + chan event $f writable {} + set x done + } + }] + after 10000 [namespace code { + set x timeout + }] + vwait [namespace which -variable x] + return $x +} -cleanup { + catch {chan close $f} +} -result done + + makeFile "foo bar" foo test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { diff --git a/tests/ioCmd.test b/tests/ioCmd.test index b15be21..a967139 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -2050,7 +2050,7 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { } -returnCodes error -result {can not find reflected channel named "rc*"} test iocmd-31.9 { chan postevent - + call to current coroutine see 67a5eabbd3d1 diff --git a/tests/link.test b/tests/link.test index 4c4cf99..51a3b65 100644 --- a/tests/link.test +++ b/tests/link.test @@ -26,6 +26,16 @@ foreach i {int real bool string} { unset -nocomplain $i } +test link-0.1 {leak test} {testlink} { + interp create i + load {} Tcltest i + i eval { + testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0 + namespace delete :: + } + interp delete i +} {} + test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup { testlink delete } -body { diff --git a/tests/upvar.test b/tests/upvar.test index 476250c..91153a6 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -356,6 +356,10 @@ test upvar-8.11 {upvar will not create a variable that looks like an array} -set test upvar-9.1 {Tcl_UpVar2 procedure} testupvar { list [catch {testupvar xyz a {} x global} msg] $msg } {1 {bad level "xyz"}} +test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar { + apply {{} {testupvar xyz a {} x local; set x foo}} + set a +} foo test upvar-9.2 {Tcl_UpVar2 procedure} testupvar { catch {unset a} catch {unset x} diff --git a/unix/Makefile.in b/unix/Makefile.in index 74bee41..2dd50b3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -685,20 +685,20 @@ ${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} @rm -rf ${TCL_VFS_ROOT} @mkdir -p ${TCL_VFS_PATH} @echo "creating ${TCL_VFS_PATH} (prepare compression)" - @( \ - ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/ && \ - ln ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl \ - ) || ( \ - cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \ - cp -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \ - ) + @if \ + ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/ && \ + ln ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \ + then : ; else \ + cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \ + cp -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \ + fi @find ${TCL_VFS_ROOT} -type d -empty -delete - (zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \ - (echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \ - cd ${TCL_VFS_ROOT} && \ - $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \ - echo "${TCL_ZIP_FILE} successful created with $$zip" && \ - cd ..) + @echo "creating ${TCL_ZIP_FILE} from ${TCL_VFS_PATH}" + @(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}' || \ + echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?") 2>/dev/null`; \ + echo 'cd ${TCL_VFS_ROOT} &&' $$zip '${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH}'; \ + cd ${TCL_VFS_ROOT} && \ + $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null) # The following target is configured by autoconf to generate either a shared # library or non-shared library for Tcl. @@ -706,9 +706,9 @@ ${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE} rm -f $@ @MAKE_LIB@ @if test "${ZIPFS_BUILD}" = "1" ; then \ - cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \ - ${NATIVE_ZIP} -A ${LIB_FILE} \ - || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ + cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \ + ${NATIVE_ZIP} -A ${LIB_FILE} \ + || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ fi ${STUB_LIB_FILE}: ${STUB_LIB_OBJS} @@ -2088,8 +2088,9 @@ checkstubs: $(TCL_LIB_FILE) checkdoc: $(TCL_LIB_FILE) -@for i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \ - | grep -v 'Cmd$$' | sort -n` ; do \ + | grep -Fv . | grep -v 'Cmd$$' | sort -n` ; do \ match=0; \ + i=`echo $$i | sed 's/^_//'`; \ for j in $(TOP_DIR)/doc/*.3 ; do \ if [ `grep '\-' $$j | grep -c $$i` -gt 0 ] ; then \ match=1; \ @@ -2105,7 +2106,7 @@ checkdoc: $(TCL_LIB_FILE) # checkuchar: - -egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR + -@egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR # # Target to make sure that only symbols with "Tcl" prefixes are exported. @@ -2125,14 +2126,17 @@ checkexports: $(TCL_LIB_FILE) # system. # +RPM_PLATFORMS = i386 rpm: all -@rm -f THIS.TCL.SPEC echo "%define _builddir `pwd`" > THIS.TCL.SPEC echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC cat tcl.spec >> THIS.TCL.SPEC - mkdir -p RPMS/i386 - rpmbuild -bb THIS.TCL.SPEC - mv RPMS/i386/*.rpm . + for platform in $(RPM_PLATFORMS); do \ + mkdir -p RPMS/$$platform && \ + rpmbuild -bb THIS.TCL.SPEC && \ + mv RPMS/$$platform/*.rpm .; \ + done -rm -rf RPMS THIS.TCL.SPEC # @@ -2155,7 +2159,8 @@ $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure cd $(MAC_OSX_DIR); autoheader; touch $@ -dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH} +dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in \ + $(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH} rm -rf $(DISTDIR) mkdir -p $(DISTDIR)/unix cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix @@ -2181,7 +2186,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M @mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library - for i in $(BUILTIN_PACKAGE_LIST) ; do \ + @for i in $(BUILTIN_PACKAGE_LIST) ; do \ mkdir $(DISTDIR)/library/$$i;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done @@ -2190,8 +2195,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M @mkdir $(DISTDIR)/library/msgs cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs @echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata - @( cd $(TOP_DIR); \ - find library/tzdata -name CVS -prune -o -type f -print ) \ + @( cd $(TOP_DIR); find library/tzdata -type f -print ) \ | ( cd $(TOP_DIR) ; xargs tar cf - ) \ | ( cd $(DISTDIR) ; tar xfp - ) @mkdir $(DISTDIR)/doc @@ -2201,8 +2205,8 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \ $(COMPAT_DIR)/README $(DISTDIR)/compat @mkdir $(DISTDIR)/compat/zlib - ( cd $(COMPAT_DIR)/zlib; \ - find . -name CVS -prune -o -type f -print ) \ + @echo cp -r $(COMPAT_DIR)/zlib $(DISTDIR)/compat/zlib + @( cd $(COMPAT_DIR)/zlib; find . -type f -print ) \ | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \ | ( cd $(DISTDIR)/compat/zlib ; tar xfp - ) @mkdir $(DISTDIR)/tests diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 25b9376..500bf97 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -17,7 +17,7 @@ TCL_VERSION= @TCL_VERSION@ CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ -CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ +CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_NO_DEPRECATED=1 LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index e963589..3e1a5c2 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -2273,6 +2273,85 @@ DefaultTempDir(void) return TCL_TEMPORARY_FILE_DIRECTORY; } +/* + *---------------------------------------------------------------------- + * + * TclpCreateTemporaryDirectory -- + * + * Creates a temporary directory, possibly based on the supplied bits and + * pieces of template supplied in the arguments. + * + * Results: + * An object (refcount 0) containing the name of the newly-created + * directory, or NULL on failure. + * + * Side effects: + * Accesses the native filesystem. Makes a directory. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpCreateTemporaryDirectory( + Tcl_Obj *dirObj, + Tcl_Obj *basenameObj) +{ + Tcl_DString template, tmp; + const char *string; + +#define DEFAULT_TEMP_DIR_PREFIX "tcl" + + /* + * Build the template in writable memory from the user-supplied pieces and + * some defaults. + */ + + if (dirObj) { + string = TclGetString(dirObj); + Tcl_UtfToExternalDString(NULL, string, dirObj->length, &template); + } else { + Tcl_DStringInit(&template); + Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */ + } + + if (Tcl_DStringValue(&template)[Tcl_DStringLength(&template) - 1] != '/') { + TclDStringAppendLiteral(&template, "/"); + } + + if (basenameObj) { + string = TclGetString(basenameObj); + if (basenameObj->length) { + Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp); + TclDStringAppendDString(&template, &tmp); + Tcl_DStringFree(&tmp); + } else { + TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX); + } + } else { + TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX); + } + + TclDStringAppendLiteral(&template, "_XXXXXX"); + + /* + * Make the temporary directory. + */ + + if (mkdtemp(Tcl_DStringValue(&template)) == NULL) { + Tcl_DStringFree(&template); + return NULL; + } + + /* + * The template has been updated. Tell the caller what it was. + */ + + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template), + Tcl_DStringLength(&template), &tmp); + Tcl_DStringFree(&template); + return TclDStringToObj(&tmp); +} + #if defined(__CYGWIN__) static void diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 14bb252..2531ba6 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1957,6 +1957,121 @@ TclpObjListVolumes(void) } /* + *---------------------------------------------------------------------- + * + * TclpCreateTemporaryDirectory -- + * + * Creates a temporary directory, possibly based on the supplied bits and + * pieces of template supplied in the arguments. + * + * Results: + * An object (refcount 0) containing the name of the newly-created + * directory, or NULL on failure. + * + * Side effects: + * Accesses the native filesystem. Makes a directory. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpCreateTemporaryDirectory( + Tcl_Obj *dirObj, + Tcl_Obj *basenameObj) +{ + Tcl_DString base, name; /* Contains WCHARs */ + int baseLen; + DWORD error; + WCHAR tempBuf[MAX_PATH + 1]; + DWORD len = GetTempPathW(MAX_PATH, tempBuf); + + /* + * Build the path in writable memory from the user-supplied pieces and + * some defaults. First, the parent temporary directory. + */ + + if (dirObj) { + Tcl_GetString(dirObj); + if (dirObj->length < 1) { + goto useSystemTemp; + } + Tcl_WinUtfToTChar(Tcl_GetString(dirObj), -1, &base); + if (dirObj->bytes[dirObj->length - 1] != '\\') { + TclUtfToWCharDString("\\", -1, &base); + } + } else { + useSystemTemp: + Tcl_DStringInit(&base); + Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR)); + } + + /* + * Next, the base of the directory name. + */ + +#define DEFAULT_TEMP_DIR_PREFIX "tcl" +#define SUFFIX_LENGTH 8 + + if (basenameObj) { + Tcl_WinUtfToTChar(Tcl_GetString(basenameObj), -1, &name); + TclDStringAppendDString(&base, &name); + Tcl_DStringFree(&name); + } else { + TclUtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base); + } + TclUtfToWCharDString("_", -1, &base); + + /* + * Now we keep on trying random suffixes until we get one that works + * (i.e., that doesn't trigger the ERROR_ALREADY_EXISTS error). Note that + * SUFFIX_LENGTH is longer than on Unix because we expect to be not on a + * case-sensitive filesystem. + */ + + baseLen = Tcl_DStringLength(&base); + do { + char tempbuf[SUFFIX_LENGTH + 1]; + int i; + static const char randChars[] = + "QWERTYUIOPASDFGHJKLZXCVBNM1234567890"; + static const int numRandChars = sizeof(randChars) - 1; + + /* + * Put a random suffix on the end. + */ + + error = ERROR_SUCCESS; + tempbuf[SUFFIX_LENGTH] = '\0'; + for (i = 0 ; i < SUFFIX_LENGTH; i++) { + tempbuf[i] = randChars[(int) (rand() % numRandChars)]; + } + Tcl_DStringSetLength(&base, baseLen); + TclUtfToWCharDString(tempbuf, -1, &base); + } while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL) + && (error = GetLastError()) == ERROR_ALREADY_EXISTS); + + /* + * Check for other errors. The big ones are ERROR_PATH_NOT_FOUND and + * ERROR_ACCESS_DENIED. + */ + + if (error != ERROR_SUCCESS) { + TclWinConvertError(error); + Tcl_DStringFree(&base); + return NULL; + } + + /* + * We actually made the directory, so we're done! Report what we made back + * as a (clean) Tcl_Obj. + */ + + Tcl_WinTCharToUtf((LPCWSTR) Tcl_DStringValue(&base), -1, &name); + Tcl_DStringFree(&base); + return TclDStringToObj(&name); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 3524a16..fa5f28e 100644..100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -680,7 +680,8 @@ NativeReadReparse( HANDLE hFile; DWORD returnedLength; - hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING, + hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { @@ -842,7 +843,7 @@ tclWinDebugPanic( #endif abort(); } - + /* *--------------------------------------------------------------------------- * @@ -1450,11 +1451,16 @@ TclpGetUserHome( if (domain == NULL) { const char *ptr; - /* no domain - firstly check it's the current user */ - if ( (ptr = TclpGetUserName(&ds)) != NULL - && strcasecmp(name, ptr) == 0 - ) { - /* try safest and fastest way to get current user home */ + /* + * No domain. Firstly check it's the current user + */ + + ptr = TclpGetUserName(&ds); + if (ptr != NULL && strcasecmp(name, ptr) == 0) { + /* + * Try safest and fastest way to get current user home + */ + ptr = TclGetEnv("HOME", &ds); if (ptr != NULL) { Tcl_JoinPath(1, &ptr, bufferPtr); @@ -1475,18 +1481,28 @@ TclpGetUserHome( wName = TclUtfToWCharDString(name, nameLen, &ds); while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) { /* - * user does not exists - if domain was not specified, - * try again using current domain. + * User does not exist; if domain was not specified, try again + * using current domain. */ + rc = 1; - if (domain != NULL) break; - /* get current domain */ + if (domain != NULL) { + break; + } + + /* + * Get current domain + */ + rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain); - if (rc != 0) break; + if (rc != 0) { + break; + } domain = INT2PTR(-1); /* repeat once */ } if (rc == 0) { DWORD i, size = MAX_PATH; + wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { size = lstrlenW(wHomeDir); @@ -1496,15 +1512,22 @@ TclpGetUserHome( * User exists but has no home dir. Return * "{GetProfilesDirectory}/<user>". */ + GetProfilesDirectoryW(buf, &size); TclWCharToUtfDString(buf, size-1, bufferPtr); Tcl_DStringAppend(bufferPtr, "/", 1); Tcl_DStringAppend(bufferPtr, name, nameLen); } result = Tcl_DStringValue(bufferPtr); - /* be sure we return normalized path */ - for (i = 0; i < size; ++i){ - if (result[i] == '\\') result[i] = '/'; + + /* + * Be sure we return normalized path + */ + + for (i = 0; i < size; ++i) { + if (result[i] == '\\') { + result[i] = '/'; + } } NetApiBufferFree((void *) uiPtr); } @@ -1592,48 +1615,72 @@ NativeAccess( /* * If it's not a directory (assume file), do several fast checks: */ + if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) { /* * If the attributes say this is not writable at all. The file is a * regular file (i.e., not a directory), then the file is not - * writable, full stop. For directories, the read-only bit is + * writable, full stop. For directories, the read-only bit is * (mostly) ignored by Windows, so we can't ascertain anything about * directory access from the attrib data. However, if we have the - * advanced 'getFileSecurityProc', then more robust ACL checks - * will be done below. + * advanced 'getFileSecurityProc', then more robust ACL checks will be + * done below. */ + if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) { Tcl_SetErrno(EACCES); return -1; } - /* If doesn't have the correct extension, it can't be executable */ + /* + * If doesn't have the correct extension, it can't be executable + */ + if ((mode & X_OK) && !NativeIsExec(nativePath)) { Tcl_SetErrno(EACCES); return -1; } - /* Special case for read/write/executable check on file */ + + /* + * Special case for read/write/executable check on file + */ + if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) { DWORD mask = 0; HANDLE hFile; - if (mode & R_OK) { mask |= GENERIC_READ; } - if (mode & W_OK) { mask |= GENERIC_WRITE; } - if (mode & X_OK) { mask |= GENERIC_EXECUTE; } + + if (mode & R_OK) { + mask |= GENERIC_READ; + } + if (mode & W_OK) { + mask |= GENERIC_WRITE; + } + if (mode & X_OK) { + mask |= GENERIC_EXECUTE; + } hFile = CreateFile(nativePath, mask, - FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, - OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL); + FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, + NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL); if (hFile != INVALID_HANDLE_VALUE) { CloseHandle(hFile); return 0; } - /* fast exit if access was denied */ + + /* + * Fast exit if access was denied + */ + if (GetLastError() == ERROR_ACCESS_DENIED) { Tcl_SetErrno(EACCES); return -1; } } - /* We cannnot verify the access fast, check it below using security info. */ + + /* + * We cannnot verify the access fast, check it below using security + * info. + */ } /* @@ -2008,13 +2055,12 @@ NativeStat( * 'getFileAttributesExProc', and if that isn't available, then on even * simpler routines. * - * Special consideration must be given to Windows hardcoded names - * like CON, NULL, COM1, LPT1 etc. For these, we still need to - * do the CreateFile as some may not exist (e.g. there is no CON - * in wish by default). However the subsequent GetFileInformationByHandle - * will fail. We do a WinIsReserved to see if it is one of the special - * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION - * structure. + * Special consideration must be given to Windows hardcoded names like + * CON, NULL, COM1, LPT1 etc. For these, we still need to do the + * CreateFile as some may not exist (e.g. there is no CON in wish by + * default). However the subsequent GetFileInformationByHandle will + * fail. We do a WinIsReserved to see if it is one of the special names, + * and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure. */ fileHandle = CreateFile(nativePath, GENERIC_READ, @@ -2032,7 +2078,11 @@ NativeStat( Tcl_SetErrno(ENOENT); return -1; } - /* Mock up the expected structure */ + + /* + * Mock up the expected structure + */ + memset(&data, 0, sizeof(data)); statPtr->st_atime = 0; statPtr->st_mtime = 0; @@ -2315,7 +2365,7 @@ TclpGetNativeCwd( } if (clientData != NULL) { - if (wcscmp((const WCHAR*)clientData, buffer) == 0) { + if (wcscmp((const WCHAR *) clientData, buffer) == 0) { return clientData; } } @@ -2543,10 +2593,12 @@ TclpObjNormalizePath( (int)(sizeof(WCHAR) * len)); lastValidPathEnd = currentPathEndPosition; } else if (nextCheckpoint == 0) { - /* Path starts with a drive designation - * that's not actually on the system. - * We still must normalize up past the - * first separator. [Bug 3603434] */ + /* + * Path starts with a drive designation that's not + * actually on the system. We still must normalize up + * past the first separator. [Bug 3603434] + */ + currentPathEndPosition++; } } @@ -2561,11 +2613,10 @@ TclpObjNormalizePath( */ /* - * 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. + * 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 && @@ -2574,8 +2625,8 @@ TclpObjNormalizePath( if (to != NULL) { /* - * Read the reparse point ok. Now, reparse points need - * not be normalized, otherwise we could use: + * Read the reparse point ok. Now, reparse points need not + * be normalized, otherwise we could use: * * Tcl_GetStringFromObj(to, &pathLen); * nextCheckpoint = pathLen; @@ -2615,9 +2666,9 @@ TclpObjNormalizePath( #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) { @@ -2646,10 +2697,10 @@ TclpObjNormalizePath( 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, ((const char *)nativePath) @@ -2667,8 +2718,7 @@ TclpObjNormalizePath( handle = FindFirstFileW((WCHAR *) nativePath, &fData); if (handle == INVALID_HANDLE_VALUE) { /* - * This is usually the '/' in 'c:/' at end of - * string. + * This is usually the '/' in 'c:/' at end of string. */ Tcl_DStringAppend(&dsNorm, (const char *) L"/", @@ -2698,8 +2748,8 @@ TclpObjNormalizePath( } /* - * 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; @@ -2993,7 +3043,11 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } - /* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */ + + /* + * refCount of validPathPtr was already incremented in + * Tcl_FSGetTranslatedPath + */ } else { /* * Make sure the normalized path is set. @@ -3003,72 +3057,100 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } - /* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */ + + /* + * validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, + * so incr refCount here + */ + Tcl_IncrRefCount(validPathPtr); } str = Tcl_GetStringFromObj(validPathPtr, &len); - if (strlen(str)!=(size_t)len) { - /* String contains NUL-bytes. This is invalid. */ + if (strlen(str) != (size_t) len) { + /* + * String contains NUL-bytes. This is invalid. + */ + goto done; } - /* For a reserved device, strip a possible postfix ':' */ + + /* + * For a reserved device, strip a possible postfix ':' + */ + len = WinIsReserved(str); if (len == 0) { - /* Let MultiByteToWideChar check for other invalid sequences, like - * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */ + /* + * Let MultiByteToWideChar check for other invalid sequences, like + * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames + */ + len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0); if (len==0) { goto done; } } - /* Overallocate 6 chars, making some room for extended paths */ - wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) ); + + /* + * Overallocate 6 chars, making some room for extended paths + */ + + wp = nativePathPtr = ckalloc((len + 6) * sizeof(WCHAR)); if (nativePathPtr==0) { goto done; } - MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1); + MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, + len + 1); + /* - ** If path starts with "//?/" or "\\?\" (extended path), translate - ** any slashes to backslashes but leave the '?' intact - */ - if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') - && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { + * If path starts with "//?/" or "\\?\" (extended path), translate any + * slashes to backslashes but leave the '?' intact + */ + + if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/') + && str[2] == '?' && (str[3] == '\\' || str[3] == '/')) { wp[0] = wp[1] = wp[3] = '\\'; str += 4; wp += 4; } + /* - ** If there is no "\\?\" prefix but there is a drive or UNC - ** path prefix and the path is larger than MAX_PATH chars, - ** no Win32 API function can handle that unless it is - ** prefixed with the extended path prefix. See: - ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath> - **/ - if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) - && str[1]==':') { - if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) { - memmove(wp+4, wp, len*sizeof(WCHAR)); - memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR)); + * If there is no "\\?\" prefix but there is a drive or UNC path prefix + * and the path is larger than MAX_PATH chars, no Win32 API function can + * handle that unless it is prefixed with the extended path prefix. See: + * <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath> + */ + + if (((str[0] >= 'A' && str[0] <= 'Z') || (str[0] >= 'a' && str[0] <= 'z')) + && str[1] == ':') { + if (wp == nativePathPtr && len > MAX_PATH + && (str[2] == '\\' || str[2] == '/')) { + memmove(wp + 4, wp, len * sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\", 4 * sizeof(WCHAR)); wp += 4; } + /* - ** If (remainder of) path starts with "<drive>:", - ** leave the ':' intact. + * If (remainder of) path starts with "<drive>:", leave the ':' + * intact. */ + wp += 2; - } else if (wp==nativePathPtr && len>MAX_PATH - && (str[0]=='\\' || str[0]=='/') - && (str[1]=='\\' || str[1]=='/') && str[2]!='?') { - memmove(wp+6, wp, len*sizeof(WCHAR)); - memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR)); + } else if (wp == nativePathPtr && len > MAX_PATH + && (str[0] == '\\' || str[0] == '/') + && (str[1] == '\\' || str[1] == '/') && str[2] != '?') { + memmove(wp + 6, wp, len * sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\UNC", 7 * sizeof(WCHAR)); wp += 7; } + /* - ** In the remainder of the path, translate invalid characters to - ** characters in the Unicode private use area. - */ + * In the remainder of the path, translate invalid characters to + * characters in the Unicode private use area. + */ + while (*wp != '\0') { if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) { *wp |= 0xF000; @@ -3079,7 +3161,6 @@ TclNativeCreateNativeRep( } done: - TclDecrRefCount(validPathPtr); return nativePathPtr; } @@ -3205,21 +3286,28 @@ TclWinFileOwned( native = Tcl_FSGetNativePath(pathPtr); if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT, - OWNER_SECURITY_INFORMATION, &ownerSid, - NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { - /* Either not a file, or we do not have access to it in which - case we are in all likelihood not the owner */ + OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL, + &secd) != ERROR_SUCCESS) { + /* + * Either not a file, or we do not have access to it in which case we + * are in all likelihood not the owner. + */ + return 0; } /* - * Getting the current process SID is a multi-step process. - * We make the assumption that if a call fails, this process is - * so underprivileged it could not possibly own anything. Normally - * a process can *always* look up its own token. + * Getting the current process SID is a multi-step process. We make the + * assumption that if a call fails, this process is so underprivileged it + * could not possibly own anything. Normally a process can *always* look + * up its own token. */ + if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) { - /* Find out how big the buffer needs to be */ + /* + * Find out how big the buffer needs to be. + */ + bufsz = 0; GetTokenInformation(token, TokenUser, NULL, 0, &bufsz); if (bufsz) { @@ -3231,15 +3319,20 @@ TclWinFileOwned( CloseHandle(token); } - /* Free allocations and be done */ - if (secd) + /* + * Free allocations and be done. + */ + + if (secd) { LocalFree(secd); /* Also frees ownerSid */ - if (buf) + } + if (buf) { ckfree(buf); + } return (owned != 0); /* Convert non-0 to 1 */ } - + /* * Local Variables: * mode: c diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index ee1e9ba..a001816 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -124,8 +124,7 @@ typedef struct PipeInfo { * 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. - */ + * 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 @@ -218,7 +217,7 @@ static const Tcl_ChannelType pipeChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc */ PipeThreadActionProc, /* thread action proc */ - NULL /* truncate */ + NULL /* truncate */ }; /* @@ -1428,9 +1427,12 @@ ApplicationType( static const char * BuildCmdLineBypassBS( const char *current, - const char **bspos -) { - /* mark first backslash possition */ + const char **bspos) +{ + /* + * Mark first backslash position. + */ + if (!*bspos) { *bspos = current; } @@ -1445,14 +1447,14 @@ QuoteCmdLineBackslash( Tcl_DString *dsPtr, const char *start, const char *current, - const char *bspos -) { + const char *bspos) +{ if (!bspos) { - if (current > start) { /* part before current (special) */ + if (current > start) { /* part before current (special) */ Tcl_DStringAppend(dsPtr, start, (int) (current - start)); } } else { - if (bspos > start) { /* part before first backslash */ + if (bspos > start) { /* part before first backslash */ Tcl_DStringAppend(dsPtr, start, (int) (bspos - start)); } while (bspos++ < current) { /* each backslash twice */ @@ -1467,38 +1469,59 @@ QuoteCmdLinePart( const char *start, const char *special, const char *specMetaChars, - const char **bspos -) { + const char **bspos) +{ if (!*bspos) { - /* rest before special (before quote) */ + /* + * Rest before special (before quote). + */ + QuoteCmdLineBackslash(dsPtr, start, special, NULL); start = special; } else { - /* rest before first backslash and backslashes into new quoted block */ + /* + * Rest before first backslash and backslashes into new quoted block. + */ + QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); start = *bspos; } + /* - * escape all special chars enclosed in quotes like `"..."`, note that here we - * don't must escape `\` (with `\`), because it's outside of the main quotes, - * so `\` remains `\`, but important - not at end of part, because results as - * before the quote, so `%\%\` should be escaped as `"%\%"\\`). + * escape all special chars enclosed in quotes like `"..."`, note that + * here we don't must escape `\` (with `\`), because it's outside of the + * main quotes, so `\` remains `\`, but important - not at end of part, + * because results as before the quote, so `%\%\` should be escaped as + * `"%\%"\\`). */ + TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ do { *bspos = NULL; special++; if (*special == '\\') { - /* bypass backslashes (and mark first backslash possition)*/ + /* + * Bypass backslashes (and mark first backslash position). + */ + special = BuildCmdLineBypassBS(special, bspos); - if (*special == '\0') break; + if (*special == '\0') { + break; + } } } while (*special && strchr(specMetaChars, *special)); if (!*bspos) { - /* unescaped rest before quote */ + /* + * Unescaped rest before quote. + */ + QuoteCmdLineBackslash(dsPtr, start, special, NULL); } else { - /* unescaped rest before first backslash (rather belongs to the main block) */ + /* + * Unescaped rest before first backslash (rather belongs to the main + * block). + */ + QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); } TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */ @@ -1517,13 +1540,14 @@ BuildCommandLine( const char *arg, *start, *special, *bspos; int quote = 0, i; Tcl_DString ds; - - /* characters to enclose in quotes if unpaired quote flag set */ static const char specMetaChars[] = "&|^<>!()%"; - /* character to enclose in quotes in any case (regardless unpaired-flag) */ + /* Characters to enclose in quotes if unpaired + * quote flag set. */ static const char specMetaChars2[] = "%"; - - /* Quote flags: + /* Character to enclose in quotes in any case + * (regardless of unpaired-flag). */ + /* + * Quote flags: * CL_ESCAPE - escape argument; * CL_QUOTE - enclose in quotes; * CL_UNPAIRED - previous arguments chain contains unpaired quote-char; @@ -1555,30 +1579,31 @@ BuildCommandLine( quote = CL_QUOTE; } else { for (start = arg; - *start != '\0' && - (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE); - start++ - ) { - if (*start & 0x80) continue; + *start != '\0' && + (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE); + start++) { + if (*start & 0x80) { + continue; + } if (TclIsSpaceProc(*start)) { - quote |= CL_QUOTE; /* quote only */ - if (bspos) { /* if backslash found - escape & quote */ + quote |= CL_QUOTE; /* quote only */ + if (bspos) { /* if backslash found, escape & quote */ quote |= CL_ESCAPE; break; } continue; } if (strchr(specMetaChars, *start)) { - quote |= (CL_ESCAPE|CL_QUOTE); /*escape & quote */ + quote |= (CL_ESCAPE|CL_QUOTE); /* escape & quote */ break; } if (*start == '"') { - quote |= CL_ESCAPE; /* escape only */ + quote |= CL_ESCAPE; /* escape only */ continue; } if (*start == '\\') { bspos = start; - if (quote & CL_QUOTE) { /* if quote - escape & quote */ + if (quote & CL_QUOTE) { /* if quote, escape & quote */ quote |= CL_ESCAPE; break; } @@ -1588,56 +1613,116 @@ BuildCommandLine( bspos = NULL; } if (quote & CL_QUOTE) { - /* start of argument (main opening quote-char) */ + /* + * Start of argument (main opening quote-char). + */ + TclDStringAppendLiteral(&ds, "\""); } if (!(quote & CL_ESCAPE)) { - /* nothing to escape */ + /* + * Nothing to escape. + */ + Tcl_DStringAppend(&ds, arg, -1); } else { start = arg; for (special = arg; *special != '\0'; ) { - /* position of `\` is important before quote or at end (equal `\"` because quoted) */ + /* + * Position of `\` is important before quote or at end (equal + * `\"` because quoted). + */ + if (*special == '\\') { - /* bypass backslashes (and mark first backslash possition)*/ + /* + * Bypass backslashes (and mark first backslash position) + */ + special = BuildCmdLineBypassBS(special, &bspos); - if (*special == '\0') break; + if (*special == '\0') { + break; + } } /* ["] */ if (*special == '"') { - quote ^= CL_UNPAIRED; /* invert unpaired flag - observe unpaired quotes */ - /* add part before (and escape backslashes before quote) */ + /* + * Invert the unpaired flag - observe unpaired quotes + */ + + quote ^= CL_UNPAIRED; + + /* + * Add part before (and escape backslashes before quote). + */ + QuoteCmdLineBackslash(&ds, start, special, bspos); bspos = NULL; - /* escape using backslash */ + + /* + * Escape using backslash + */ + TclDStringAppendLiteral(&ds, "\\\""); start = ++special; continue; } - /* unpaired (escaped) quote causes special handling on meta-chars */ + + /* + * Unpaired (escaped) quote causes special handling on + * meta-chars + */ + if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) { - special = QuoteCmdLinePart(&ds, start, special, specMetaChars, &bspos); - /* start to current or first backslash */ + special = QuoteCmdLinePart(&ds, start, special, + specMetaChars, &bspos); + + /* + * Start to current or first backslash + */ + start = !bspos ? special : bspos; continue; } - /* special case for % - should be enclosed always (paired also) */ + + /* + * Special case for % - should be enclosed always (paired + * also) + */ + if (strchr(specMetaChars2, *special)) { - special = QuoteCmdLinePart(&ds, start, special, specMetaChars2, &bspos); - /* start to current or first backslash */ + special = QuoteCmdLinePart(&ds, start, special, + specMetaChars2, &bspos); + + /* + * Start to current or first backslash. + */ + start = !bspos ? special : bspos; continue; } - /* other not special (and not meta) character */ - bspos = NULL; /* reset last backslash possition (not interesting) */ + + /* + * Other not special (and not meta) character + */ + + bspos = NULL; /* reset last backslash position (not + * interesting) */ special++; } - /* rest of argument (and escape backslashes before closing main quote) */ + + /* + * Rest of argument (and escape backslashes before closing main + * quote) + */ + QuoteCmdLineBackslash(&ds, start, special, - (quote & CL_QUOTE) ? bspos : NULL); + (quote & CL_QUOTE) ? bspos : NULL); } if (quote & CL_QUOTE) { - /* end of argument (main closing quote-char) */ + /* + * End of argument (main closing quote-char) + */ + TclDStringAppendLiteral(&ds, "\""); } } @@ -2175,8 +2260,9 @@ PipeOutputProc( *errorCode = 0; /* avoid blocking if pipe-thread exited */ - timeout = ((infoPtr->flags & PIPE_ASYNC) || !TclPipeThreadIsAlive(&infoPtr->writeTI) - || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; + timeout = ((infoPtr->flags & PIPE_ASYNC) + || !TclPipeThreadIsAlive(&infoPtr->writeTI) + || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* * The writer thread is blocked waiting for a write to complete and @@ -2362,6 +2448,7 @@ PipeWatchProc( infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; + if (!oldMask) { infoPtr->nextPtr = tsdPtr->firstPipePtr; tsdPtr->firstPipePtr = infoPtr; @@ -2831,7 +2918,7 @@ static DWORD WINAPI PipeReaderThread( LPVOID arg) { - TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg; PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ HANDLE handle = NULL; DWORD count, err; @@ -2842,13 +2929,14 @@ PipeReaderThread( * Wait for the main thread to signal before attempting to wait on the * pipe becoming readable. */ + if (!TclPipeThreadWaitForSignal(&pipeTI)) { /* exit */ break; } if (!infoPtr) { - infoPtr = (PipeInfo *)pipeTI->clientData; + infoPtr = (PipeInfo *) pipeTI->clientData; handle = ((WinFile *) infoPtr->readFile)->handle; } @@ -3194,7 +3282,7 @@ TclPipeThreadCreateTI( pipeTI = malloc(sizeof(TclPipeThreadInfo)); #else pipeTI = ckalloc(sizeof(TclPipeThreadInfo)); -#endif +#endif /* !_PTI_USE_CKALLOC */ pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL); pipeTI->state = PTI_STATE_IDLE; pipeTI->clientData = clientData; @@ -3233,40 +3321,64 @@ TclPipeThreadWaitForSignal( } wakeEvent = pipeTI->evWakeUp; + /* * Wait for the main thread to signal before attempting to do the work. */ - /* reset work state of thread (idle/waiting) */ - if ((state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_IDLE, PTI_STATE_WORK)) & (PTI_STATE_STOP|PTI_STATE_END)) { - /* end of work, check the owner of structure */ + /* + * Reset work state of thread (idle/waiting) + */ + + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_IDLE, + PTI_STATE_WORK); + if (state & (PTI_STATE_STOP|PTI_STATE_END)) { + /* + * End of work, check the owner of structure. + */ + goto end; } - /* entering wait */ - waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE); - if (waitResult != WAIT_OBJECT_0) { + /* + * Entering wait + */ + waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE); + if (waitResult != WAIT_OBJECT_0) { /* * The control event was not signaled, so end of work (unexpected * behaviour, main thread can be dead?). */ + goto end; } - /* try to set work state of thread */ - if ((state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_WORK, PTI_STATE_IDLE)) & (PTI_STATE_STOP|PTI_STATE_END)) { - /* end of work */ + /* + * Try to set work state of thread + */ + + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_WORK, + PTI_STATE_IDLE); + if (state & (PTI_STATE_STOP|PTI_STATE_END)) { + /* + * End of work + */ + goto end; } - /* signaled to work */ + /* + * Signaled to work. + */ + return 1; -end: - /* end of work, check the owner of the TI structure */ + end: + /* + * End of work, check the owner of the TI structure. + */ + if (state != PTI_STATE_STOP) { *pipeTIPtr = NULL; } else { @@ -3296,7 +3408,8 @@ end: int TclPipeThreadStopSignal( - TclPipeThreadInfo **pipeTIPtr, HANDLE wakeEvent) + TclPipeThreadInfo **pipeTIPtr, + HANDLE wakeEvent) { TclPipeThreadInfo *pipeTI = *pipeTIPtr; HANDLE evControl; @@ -3307,28 +3420,27 @@ TclPipeThreadStopSignal( } evControl = pipeTI->evControl; pipeTI->evWakeUp = wakeEvent; - switch ( - (state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_STOP, PTI_STATE_IDLE)) - ) { - - case PTI_STATE_IDLE: - - /* Thread was idle/waiting, notify it goes teardown */ - SetEvent(evControl); - - *pipeTIPtr = NULL; - - case PTI_STATE_DOWN: + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP, + PTI_STATE_IDLE); + switch (state) { + case PTI_STATE_IDLE: + /* + * Thread was idle/waiting, notify it goes teardown + */ + SetEvent(evControl); + *pipeTIPtr = NULL; + case PTI_STATE_DOWN: return 1; - default: - /* - * Thread works currently, we should try to end it, own the TI structure - * (because of possible sharing the joint structures with thread) - */ - InterlockedExchange(&pipeTI->state, PTI_STATE_END); + default: + /* + * Thread works currently, we should try to end it, own the TI + * structure (because of possible sharing the joint structures with + * thread) + */ + + InterlockedExchange(&pipeTI->state, PTI_STATE_END); break; } @@ -3371,46 +3483,63 @@ TclPipeThreadStop( pipeTI = *pipeTIPtr; evControl = pipeTI->evControl; pipeTI->evWakeUp = NULL; + /* * Try to sane stop the pipe worker, corresponding its current state */ - switch ( - (state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_STOP, PTI_STATE_IDLE)) - ) { - case PTI_STATE_IDLE: + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP, + PTI_STATE_IDLE); + switch (state) { + case PTI_STATE_IDLE: + /* + * Thread was idle/waiting, notify it goes teardown + */ - /* Thread was idle/waiting, notify it goes teardown */ - SetEvent(evControl); + SetEvent(evControl); - /* we don't need to wait for it at all, thread frees himself (owns the TI structure) */ - pipeTI = NULL; + /* + * We don't need to wait for it at all, thread frees himself (owns the + * TI structure) + */ + + pipeTI = NULL; break; - case PTI_STATE_STOP: - /* already stopped, thread frees himself (owns the TI structure) */ - pipeTI = NULL; + case PTI_STATE_STOP: + /* + * Already stopped, thread frees himself (owns the TI structure) + */ + + pipeTI = NULL; break; - case PTI_STATE_DOWN: - /* Thread already down (?), do nothing */ + case PTI_STATE_DOWN: + /* + * Thread already down (?), do nothing + */ - /* we don't need to wait for it, but we should free pipeTI */ - hThread = NULL; + /* + * We don't need to wait for it, but we should free pipeTI + */ + hThread = NULL; break; /* case PTI_STATE_WORK: */ - default: + default: + /* + * Thread works currently, we should try to end it, own the TI + * structure (because of possible sharing the joint structures with + * thread) + */ + + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_END, + PTI_STATE_WORK); + if (state == PTI_STATE_DOWN) { /* - * Thread works currently, we should try to end it, own the TI structure - * (because of possible sharing the joint structures with thread) + * We don't need to wait for it, but we should free pipeTI */ - if ((state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_END, PTI_STATE_WORK)) == PTI_STATE_DOWN - ) { - /* we don't need to wait for it, but we should free pipeTI */ - hThread = NULL; - }; + hThread = NULL; + } break; } @@ -3425,8 +3554,8 @@ TclPipeThreadStop( GetExitCodeThread(hThread, &exitCode); if (exitCode == STILL_ACTIVE) { - int inExit = (TclInExit() || TclInThreadExit()); + /* * Set the stop event so that if the pipe thread is blocked * somewhere, it may hereafter sane exit cleanly. @@ -3437,59 +3566,69 @@ TclPipeThreadStop( /* * Cancel all sync-IO of this thread (may be blocked there). */ + if (tclWinProcs.cancelSynchronousIo) { tclWinProcs.cancelSynchronousIo(hThread); } /* - * Wait at most 20 milliseconds for the reader thread to - * close (regarding TIP#398-fast-exit). + * Wait at most 20 milliseconds for the reader thread to close + * (regarding TIP#398-fast-exit). */ - /* if we want TIP#398-fast-exit. */ - if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) { + /* + * If we want TIP#398-fast-exit. + */ + if (WaitForSingleObject(hThread, inExit ? 0 : 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. + * 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. * - * 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. + * 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. * - * Also note that terminating threads during their initialization or teardown phase - * may result in ntdll.dll's LoaderLock to remain locked indefinitely. - * This causes ntdll.dll's LdrpInitializeThread() to deadlock trying to acquire LoaderLock. - * LdrpInitializeThread() is executed within new threads to perform - * initialization and to execute DllMain() of all loaded dlls. - * As a result, all new threads are deadlocked in their initialization phase and never execute, - * even though CreateThread() reports successful thread creation. - * This results in a very weird process-wide behavior, which is extremely hard to debug. + * Also note that terminating threads during their + * initialization or teardown phase may result in ntdll.dll's + * LoaderLock to remain locked indefinitely. This causes + * ntdll.dll's LdrpInitializeThread() to deadlock trying to + * acquire LoaderLock. LdrpInitializeThread() is executed + * within new threads to perform initialization and to execute + * DllMain() of all loaded dlls. As a result, all new threads + * are deadlocked in their initialization phase and never + * execute, even though CreateThread() reports successful + * thread creation. This results in a very weird process-wide + * behavior, which is extremely hard to debug. * * THREADS SHOULD NEVER BE TERMINATED. Period. * - * But for now, check if thread is exiting, and if so, let it die peacefully. + * But for now, check if thread is exiting, and if so, let it + * die peacefully. * - * Also don't terminate if in exit (otherwise deadlocked in ntdll.dll's). + * Also don't terminate if in exit (otherwise deadlocked in + * ntdll.dll's). */ - if ( pipeTI->state != PTI_STATE_DOWN - && WaitForSingleObject(hThread, - inExit ? 50 : 5000) != WAIT_OBJECT_0 - ) { + if (pipeTI->state != PTI_STATE_DOWN + && WaitForSingleObject(hThread, + inExit ? 50 : 5000) != WAIT_OBJECT_0) { /* BUG: this leaks memory */ if (inExit || !TerminateThread(hThread, 0)) { - /* in exit or terminate fails, just give thread a chance to exit */ + /* + * in exit or terminate fails, just give thread a + * chance to exit + */ + if (InterlockedExchange(&pipeTI->state, PTI_STATE_STOP) != PTI_STATE_DOWN) { pipeTI = NULL; } - }; + } } } } @@ -3501,11 +3640,11 @@ TclPipeThreadStop( SetEvent(pipeTI->evWakeUp); } CloseHandle(pipeTI->evControl); -# ifndef _PTI_USE_CKALLOC +#ifndef _PTI_USE_CKALLOC free(pipeTI); -# else +#else ckfree(pipeTI); -# endif +#endif /* !_PTI_USE_CKALLOC */ } } @@ -3534,28 +3673,30 @@ TclPipeThreadExit( { LONG state; TclPipeThreadInfo *pipeTI = *pipeTIPtr; + /* * If state of thread was set to stop (exactly), we can sane free its info * structure, otherwise it is shared with main thread, so main thread will * own it. */ + if (!pipeTI) { return; } *pipeTIPtr = NULL; - if ((state = InterlockedExchange(&pipeTI->state, - PTI_STATE_DOWN)) == PTI_STATE_STOP) { + state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN); + if (state == PTI_STATE_STOP) { CloseHandle(pipeTI->evControl); if (pipeTI->evWakeUp) { SetEvent(pipeTI->evWakeUp); } -# ifndef _PTI_USE_CKALLOC +#ifndef _PTI_USE_CKALLOC free(pipeTI); -# else +#else ckfree(pipeTI); /* be sure all subsystems used are finalized */ Tcl_FinalizeThread(); -# endif +#endif /* !_PTI_USE_CKALLOC */ } } |