From a6445ff24759b945d19fcb079751a57747d5e527 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Sep 2007 17:58:23 +0000 Subject: merge updates from HEAD --- ChangeLog | 42 +++++++ doc/package.n | 29 ++--- generic/tclCompCmds.c | 50 +++++--- generic/tclCompile.c | 6 +- generic/tclExecute.c | 37 ++++-- generic/tclLink.c | 11 +- generic/tclPkg.c | 333 ++++++++++++++------------------------------------ tests/pkg.test | 32 +++-- 8 files changed, 234 insertions(+), 306 deletions(-) diff --git a/ChangeLog b/ChangeLog index bcb5eaf..8565b7d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,45 @@ +2007-09-11 Don Porter + + * doc/package.n: Restored the functioning of + * generic/tclPkg.c: [package require -exact] to be compatible + * tests/pkg.test: with Tcl 8.4. [Bug 1578344]. + +2007-09-11 Miguel Sofer + + * generic/tclCompCmds.c (TclCompileDictCmd-update): + * generic/tclCompile.c (tclInstructionTable): + * generic/tclExecute.c (INST_DICT_UPDATE_END): fix stack + management in [dict update] [Bug 1786481]. + + ***POTENTIAL INCOMPATIBILITY*** + Scripts that were precompiled on earlier versions of 8.5 and use + [dict update] will crash. Workaround: recompile. + +2007-09-11 Kevin B. Kenny + + * generic/tclExecute.c: Corrected an off-by-one error in the + setting of MaxBaseWide for certain powers. [Bug 1767293 - + problem reported in comments when bug was reopened]. + +2007-09-10 Jeff Hobbs + + * generic/tclLink.c (Tcl_UpdateLinkedVar): guard against var being + unlinked. [Bug 1740631] (maros) + +2007-09-10 Miguel Sofer + + * generic/tclCompile.c: fix tclInstructionTable entry for + dictUpdateEnd + + * generic/tclExecute.c: remove unneeded setting of 'cleanup' + variable before jumping to checkForCatch. + +2007-09-10 Don Porter + + * doc/package.n: Restored the document parallel syntax of the + * generic/tclPkg.c: [package present] and [package require] + * tests/pkg.test: commands. [Bug 1723675] + 2007-09-09 Don Porter * generic/tclInt.h: Removed the "nsName" Tcl_ObjType from the diff --git a/doc/package.n b/doc/package.n index 9d2d3af..cfa7eaf 100644 --- a/doc/package.n +++ b/doc/package.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: package.n,v 1.15 2006/10/05 05:13:13 hobbs Exp $ +'\" RCS: @(#) $Id: package.n,v 1.15.6.1 2007/09/11 17:58:23 dgp Exp $ '\" .so man.macros .TH package n 7.5 Tcl "Tcl Built-In Commands" @@ -17,9 +17,11 @@ package \- Facilities for package loading and version control \fBpackage forget ?\fIpackage package ...\fR? \fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? \fBpackage names\fR -\fBpackage present \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR? +\fBpackage present \fIpackage \fR?\fIrequirement...\fR? +\fBpackage present \-exact \fIpackage version\fR \fBpackage provide \fIpackage \fR?\fIversion\fR? -\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIrequirement...\fR? +\fBpackage require \fIpackage \fR?\fIrequirement...\fR? +\fBpackage require \-exact \fIpackage version\fR \fBpackage unknown \fR?\fIcommand\fR? \fBpackage vcompare \fIversion1 version2\fR \fBpackage versions \fIpackage\fR @@ -77,7 +79,7 @@ interpreter for which a version has been provided (via script is available. The order of elements in the list is arbitrary. .TP -\fBpackage present \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR? +\fBpackage present\fR This command is equivalent to \fBpackage require\fR except that it does not try and load the package if it is not already loaded. .TP @@ -93,20 +95,6 @@ returns the version number that is currently provided, or an empty string if no \fBpackage provide\fR command has been invoked for \fIpackage\fR in this interpreter. .TP -\fBpackage require \fR\fB\-exact\fR \fIpackage \fR\fIversion\fR -This form of the command is translated to the form below using the -bounded requirement "version-(version+1)", making only the given -\fIversion\fR acceptable, within the specified level of detail. Deeper -levels are allowed to vary. Examples: -.CS - -exact 8 => 8-9 - -exact 8.4 => 8.4-8.5 - -exact 8.4.14 => 8.4.14-8.4.15 -.CE -.RS -For more explanations see below. -.RE -.TP \fBpackage require \fR\fIpackage \fR?\fIrequirement...\fR? This command is typically invoked by Tcl code that wishes to use a particular version of a particular package. The arguments @@ -149,6 +137,11 @@ If all of these steps fail to provide an acceptable version of the package, then the command returns an error. .RE .TP +\fBpackage require \-exact \fIpackage version\fR +This form of the command is used when only the given \fIversion\fR +of \fIpackage\fR is acceptable to the caller. This command is +equivalent to \fBpackage require \fIpackage version\fR-\fIversion\fR. +.TP \fBpackage unknown \fR?\fIcommand\fR? This command supplies a ``last resort'' command to invoke during \fBpackage require\fR if no suitable version of a package can be found diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 28c0fdb..2cc9a37 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.6 2007/09/09 17:26:34 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.7 2007/09/11 17:58:24 dgp Exp $ */ #include "tclInt.h" @@ -909,10 +909,12 @@ TclCompileDictCmd( return TCL_OK; } else if (size==6 && strncmp(cmd, "update", 6)==0) { const char *name; - int nameChars, dictIndex, keyTmpIndex, numVars, range, infoIndex; + int nameChars, dictIndex, numVars, range, infoIndex; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr; DictUpdateInfo *duiPtr; - + JumpFixup jumpFixup; + + /* * Parse the command. Expect the following: * dict update ? ...? @@ -965,8 +967,6 @@ TclCompileDictCmd( } bodyTokenPtr = tokenPtr; - keyTmpIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr); - /* * The list of variables to bind is stored in auxiliary data so that * it can't be snagged by literal sharing and forced to shimmer @@ -979,7 +979,6 @@ TclCompileDictCmd( CompileWord(envPtr, keyTokenPtrs[i], interp, i); } TclEmitInstInt4( INST_LIST, numVars, envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); @@ -990,27 +989,44 @@ TclCompileDictCmd( CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); + /* + * Normal termination code: the stack has the key list below the + * result of the body evaluation: swap them and finish the update + * code. + */ + TclEmitOpcode( INST_END_CATCH, envPtr); - - TclEmitInstInt4( INST_LOAD_SCALAR4, keyTmpIndex, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); /* - * Now remove the contents of the temporary key variable so that the - * reference counts of the keys end up correct. Unsetting the variable - * would be better, but there's no opcode for that. + * Jump around the exceptional termination code */ + + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - PushLiteral(envPtr, "", 0); - TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + /* + * Termination code for non-ok returns: stash the result and return + * options in the stack, bring up the key list, finish the update + * code, and finally return with the catched return data + */ + + ExceptionRangeTarget(envPtr, range, catchOffset); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); + + if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", + CurrentOffset(envPtr) - jumpFixup.codeOffset); + } TclStackFree(interp, keyTokenPtrs); return TCL_OK; } else if (size==6 && strncmp(cmd, "append", 6) == 0) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bc1715e..4249a5c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.117.2.8 2007/09/09 17:26:35 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.117.2.9 2007/09/11 17:58:24 dgp Exp $ */ #include "tclInt.h" @@ -351,14 +351,14 @@ InstructionDesc tclInstructionTable[] = { * Stack: ... => ... value key doneBool */ {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, /* Terminate the iterator in op4's local scalar. */ - {"dictUpdateStart", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}}, + {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, /* Create the variables (described in the aux data referred to by the * second immediate argument) to mirror the state of the dictionary in * the variable referred to by the first immediate argument. The list * of keys (popped from the stack) must be the same length as the list * of variables. * Stack: ... keyList => ... */ - {"dictUpdateEnd", 9, -1, 1, {OPERAND_LVT4, OPERAND_AUX4}}, + {"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}}, /* Reflect the state of local variables (described in the aux data * referred to by the second immediate argument) back to the state of * the dictionary in the variable referred to by the first immediate diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f57482f..e8e3114 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.285.2.16 2007/09/10 03:06:45 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.285.2.17 2007/09/11 17:58:24 dgp Exp $ */ #include "tclInt.h" @@ -621,7 +621,8 @@ InitByteCodeExecution( * instruction tracing. */ { #if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - int i; + int i, j; + Tcl_WideInt w, x; #endif #ifdef TCL_COMPILE_DEBUG if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, @@ -634,8 +635,29 @@ InitByteCodeExecution( (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); #endif /* TCL_COMPILE_STATS */ #if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) + + /* + * Fill in a table of what base can be raised to powers 2, 3, ... 16 + * without overflowing a Tcl_WideInt + */ for (i = 2; i <= 16; ++i) { - MaxBaseWide[i-2] = (Tcl_WideInt) pow((double) LLONG_MAX, 1.0 / i); + + /* Compute an initial guess in floating point */ + + w = (Tcl_WideInt) pow((double) LLONG_MAX, 1.0 / i) + 1; + + /* Correct the guess if it's too high */ + + for (;;) { + x = LLONG_MAX; + for (j = 0; j < i; ++j) { + x /= w; + } + if (x == 1) break; + --w; + } + + MaxBaseWide[i-2] = w; } #endif } @@ -6276,7 +6298,6 @@ TclExecuteByteCode( opnd, O2S(OBJ_AT_DEPTH(opnd))), Tcl_GetObjResult(interp)); result = TCL_ERROR; - cleanup = opnd + 1; goto checkForCatch; } } @@ -6296,7 +6317,6 @@ TclExecuteByteCode( TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); result = TCL_ERROR; } - cleanup = opnd + 1; goto checkForCatch; case INST_DICT_SET: @@ -6412,7 +6432,6 @@ TclExecuteByteCode( case INST_DICT_APPEND: case INST_DICT_LAPPEND: opnd = TclGetUInt4AtPtr(pc+1); - cleanup = 2; varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { @@ -6543,7 +6562,6 @@ TclExecuteByteCode( &valuePtr, &done); if (result != TCL_OK) { ckfree((char *) searchPtr); - cleanup = 0; goto checkForCatch; } TclNewObj(statePtr); @@ -6675,13 +6693,12 @@ TclExecuteByteCode( duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); dictUpdateStartFailed: - cleanup = 1; result = TCL_ERROR; goto checkForCatch; } CACHE_STACK_INFO(); } - NEXT_INST_F(9, 1, 0); + NEXT_INST_F(9, 0, 0); case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); @@ -6705,7 +6722,6 @@ TclExecuteByteCode( if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || Tcl_ListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { - cleanup = 1; result = TCL_ERROR; goto checkForCatch; } @@ -6751,7 +6767,6 @@ TclExecuteByteCode( if (allocdict) { Tcl_DecrRefCount(dictPtr); } - cleanup = 2; result = TCL_ERROR; goto checkForCatch; } diff --git a/generic/tclLink.c b/generic/tclLink.c index 0f33c03..6973e19 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLink.c,v 1.22 2007/05/07 19:45:33 dgp Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.22.2.1 2007/09/11 17:58:25 dgp Exp $ */ #include "tclInt.h" @@ -215,7 +215,14 @@ Tcl_UpdateLinkedVar( linkPtr->flags |= LINK_BEING_UPDATED; Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; + /* + * Callback may have unlinked the variable. [Bug 1740631] + */ + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr != NULL) { + linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; + } } /* diff --git a/generic/tclPkg.c b/generic/tclPkg.c index dff6090..abd83b1 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPkg.c,v 1.27 2007/04/20 06:10:58 kennykb Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.27.2.1 2007/09/11 17:58:25 dgp Exp $ * * TIP #268. * Heavily rewritten to handle the extend version numbers, and extended @@ -64,16 +64,16 @@ static int CheckRequirement(Tcl_Interp *interp, static int CheckAllRequirements(Tcl_Interp *interp, int reqc, Tcl_Obj *CONST reqv[]); static int RequirementSatisfied(char *havei, CONST char *req); -static int AllRequirementsSatisfied(char *havei, int reqc, +static int SomeRequirementSatisfied(char *havei, int reqc, Tcl_Obj *CONST reqv[]); static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, Tcl_Obj *CONST reqv[]); static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *CONST reqv[]); static Package * FindPackage(Tcl_Interp *interp, CONST char *name); -static Tcl_Obj * ExactRequirement(CONST char *version); -static void VersionCleanupProc(ClientData clientData, - Tcl_Interp *interp); +static const char * PkgRequireCore(Tcl_Interp *interp, CONST char *name, + int reqc, Tcl_Obj *CONST reqv[], + ClientData *clientDataPtr); /* * Helper macros. @@ -218,7 +218,7 @@ Tcl_PkgRequireEx( * call fails for any reason. */ { Tcl_Obj *ov; - int res; + const char *result = NULL; /* * If an attempt is being made to load this into a standalone executable @@ -294,53 +294,47 @@ Tcl_PkgRequireEx( /* Translate between old and new API, and defer to the new function. */ if (version == NULL) { - res = Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr); + result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); } else { + if (exact && TCL_OK + != CheckVersionAndConvert(interp, version, NULL, NULL)) { + return NULL; + } + ov = Tcl_NewStringObj(version, -1); if (exact) { - ov = ExactRequirement(version); - } else { - ov = Tcl_NewStringObj(version, -1); + Tcl_AppendStringsToObj(ov, "-", version, NULL); } - Tcl_IncrRefCount(ov); - res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr); + result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); TclDecrRefCount(ov); } - if (res != TCL_OK) { - return NULL; - } + return result; +} - /* - * This function returns the version string explictly, and leaves the - * interpreter result empty. However "Tcl_PkgRequireProc" above returned - * the version through the interpreter result. Simply resetting the result - * now potentially deletes the string (obj), and the pointer to its string - * rep we have, as our result, may be dangling due to this. Our solution - * is to remember the object in interp associated data, with a proper - * reference count, and then reset the result. Now pointers will not - * dangle. It will be a leak however if nothing is done. So the next time - * we come through here we delete the object remembered by this call, as - * we can then be sure that there is no pointer to its string around - * anymore. Beyond that we have a deletion function which cleans up the - * last remembered object which was not cleaned up directly, here. - */ +int +Tcl_PkgRequireProc( + Tcl_Interp *interp, /* Interpreter in which package is now + * available. */ + CONST char *name, /* Name of desired package. */ + int reqc, /* Requirements constraining the desired + * version. */ + Tcl_Obj *CONST reqv[], /* 0 means to use the latest version + * available. */ + ClientData *clientDataPtr) +{ + const char *result = + PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); - ov = (Tcl_Obj *) Tcl_GetAssocData(interp, "tcl/Tcl_PkgRequireEx", NULL); - if (ov != NULL) { - TclDecrRefCount(ov); + if (result == NULL) { + return TCL_ERROR; } - - ov = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(ov); - Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc, ov); - Tcl_ResetResult(interp); - - return TclGetString(ov); + Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); + return TCL_OK; } -int -Tcl_PkgRequireProc( +static const char * +PkgRequireCore( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ CONST char *name, /* Name of desired package. */ @@ -384,7 +378,7 @@ Tcl_PkgRequireProc( "attempt to provide ", name, " ", (char *) pkgPtr->clientData, " requires ", name, NULL); AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + return NULL; } /* @@ -436,7 +430,7 @@ Tcl_PkgRequireProc( * Check satisfaction of requirements. */ - satisfies = AllRequirementsSatisfied(availVersion,reqc,reqv); + satisfies = SomeRequirementSatisfied(availVersion,reqc,reqv); if (!satisfies) { ckfree(availVersion); availVersion = NULL; @@ -562,7 +556,7 @@ Tcl_PkgRequireProc( pkgPtr->version = NULL; } pkgPtr->clientData = NULL; - return TCL_ERROR; + return NULL; } break; @@ -600,7 +594,7 @@ Tcl_PkgRequireProc( if (code == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); - return TCL_ERROR; + return NULL; } Tcl_ResetResult(interp); } @@ -609,7 +603,7 @@ Tcl_PkgRequireProc( if (pkgPtr->version == NULL) { Tcl_AppendResult(interp, "can't find package ", name, NULL); AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + return NULL; } /* @@ -621,7 +615,7 @@ Tcl_PkgRequireProc( satisfies = 1; } else { CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); - satisfies = AllRequirementsSatisfied(pkgVersionI, reqc, reqv); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); } @@ -630,14 +624,13 @@ Tcl_PkgRequireProc( if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); - return TCL_OK; + return pkgPtr->version; } Tcl_AppendResult(interp, "version conflict for package \"", name, "\": have ", pkgPtr->version, ", need", NULL); AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + return NULL; } /* @@ -693,53 +686,20 @@ Tcl_PkgPresentEx( Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Package *pkgPtr; - int satisfies, result; hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - char *pvi, *vi; - int thisIsMajor; /* * At this point we know that the package is present. Make sure - * that the provided version meets the current requirement. + * that the provided version meets the current requirement by + * calling Tcl_PkgRequireEx() to check for us. */ - if (version == NULL) { - if (clientDataPtr) { - *clientDataPtr = pkgPtr->clientData; - } - - return pkgPtr->version; - } - - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, - NULL) != TCL_OK) { - return NULL; - } else if (CheckVersionAndConvert(interp, version, &vi, - NULL) != TCL_OK) { - ckfree(pvi); - return NULL; - } - - result = CompareVersions(pvi, vi, &thisIsMajor); - ckfree(pvi); - ckfree(vi); - - satisfies = (result == 0) || ((result == 1) && !thisIsMajor); - - if ((satisfies && !exact) || (result == 0)) { - if (clientDataPtr) { - *clientDataPtr = pkgPtr->clientData; - } - - return pkgPtr->version; - } - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need ", version, NULL); - return NULL; + return Tcl_PkgRequireEx(interp, name, version, exact, + clientDataPtr); } } @@ -914,39 +874,51 @@ Tcl_PackageObjCmd( } } break; - case PKG_PRESENT: + case PKG_PRESENT: { + const char *name; if (objc < 3) { - presentSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); - return TCL_ERROR; + goto require; } argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + if (objc != 5) { + goto requireSyntax; + } exact = 1; + name = TclGetString(objv[3]); } else { exact = 0; + name = argv2; + } + + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); + if (hPtr != NULL) { + pkgPtr = Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + goto require; + } } + version = NULL; - if (objc == (4 + exact)) { - version = TclGetString(objv[3 + exact]); + if (exact) { + version = TclGetString(objv[4]); if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { return TCL_ERROR; } - } else if ((objc != 3) || exact) { - goto presentSyntax; - } - if (exact) { - argv3 = TclGetString(objv[3]); - version = Tcl_PkgPresent(interp, argv3, version, exact); } else { - version = Tcl_PkgPresent(interp, argv2, version, exact); - } - if (version == NULL) { - return TCL_ERROR; + if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { + return TCL_ERROR; + } + if ((objc > 3) && (CheckVersionAndConvert(interp, + TclGetString(objv[3]), NULL, NULL) == TCL_OK)) { + version = TclGetString(objv[3]); + } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(version, -1)); + Tcl_PkgPresent(interp, name, version, exact); + return TCL_ERROR; break; + } case PKG_PROVIDE: if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); @@ -969,6 +941,7 @@ Tcl_PackageObjCmd( } return Tcl_PkgProvide(interp, argv2, argv3); case PKG_REQUIRE: + require: if (objc < 3) { requireSyntax: Tcl_WrongNumArgs(interp, 2, objv, @@ -997,7 +970,8 @@ Tcl_PackageObjCmd( * Create a new-style requirement for the exact version. */ - ov = ExactRequirement(version); + ov = Tcl_NewStringObj(version, -1); + Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); @@ -1134,7 +1108,7 @@ Tcl_PackageObjCmd( return TCL_ERROR; } - satisfies = AllRequirementsSatisfied(argv2i, objc-3, objv+3); + satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); ckfree(argv2i); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); @@ -1662,7 +1636,15 @@ AddRequirementsToResult( int i; for (i = 0; i < reqc; i++) { - Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL); + int length; + char *v = Tcl_GetStringFromObj(reqv[i], &length); + + if ((length & 0x1) && (v[length/2] == '-') + && (strncmp(v, v+((length+1)/2), length/2) == 0)) { + Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL); + } else { + Tcl_AppendResult(interp, " ", v, NULL); + } } } } @@ -1706,7 +1688,7 @@ AddRequirementsToDString( /* *---------------------------------------------------------------------- * - * AllRequirementSatisfied -- + * SomeRequirementSatisfied -- * * This function checks to see whether a version satisfies at least one * of a set of requirements. @@ -1723,7 +1705,7 @@ AddRequirementsToDString( */ static int -AllRequirementsSatisfied( +SomeRequirementSatisfied( char *availVersionI, /* Candidate version to check against the * requirements. */ int reqc, /* Requirements constraining the desired @@ -1843,139 +1825,6 @@ RequirementSatisfied( } /* - *---------------------------------------------------------------------- - * - * ExactRequirement -- - * - * This function is the core for the translation of -exact requests. It - * translates the request of the version into a range of versions. The - * translation was chosen for backwards compatibility. - * - * Results: - * A Tcl_Obj containing the version range as string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -ExactRequirement( - CONST char *version) -{ - /* - * A -exact request for a version X.y is translated into the range - * X.y-X.(y+1). For example -exact 8.4 means the range "8.4-8.5". - * - * This translation was chosen to prevent packages which currently use a - * 'package require -exact tclversion' from being affected by the core now - * registering itself as 8.4.x (patchlevel) instead of 8.4 (version). - * Examples are tbcload, compiler, and ITcl. - * - * Translating -exact 8.4 to the range "8.4-8.4" instead would require us - * and everyone else to rebuild these packages to require -exact 8.4.14, - * or whatever the exact current patchlevel is. A backward compatibility - * issue with effects similar to the bugfix made in 8.5 now requiring - * ifneeded and provided versions to match. Instead we have chosen to - * interpret exactness to not be exactly equal, but to be exact only - * within the specified level, and allowing variation in the deeper level. - * More examples: - * - * -exact 8 => "8-9" - * -exact 8.4 => "8.4-8.5" - * -exact 8.4.14 => "8.4.14-8.4.15" - * -exact 8.0a2 => "8.0a2-8.0a3" - */ - - char *iv, buf[30]; - int lc, i; - CONST char **lv; - Tcl_Obj *objPtr = Tcl_NewStringObj(version, -1); - - Tcl_AppendStringsToObj(objPtr, "-", NULL); - - /* - * Assuming valid syntax here. - */ - - CheckVersionAndConvert(NULL, version, &iv, NULL); - - /* - * Split the list into components. - */ - - Tcl_SplitList(NULL, iv, &lc, &lv); - - /* - * Iterate over the components and make them parts of the result. Except - * for the last, which is handled separately, to allow the incrementation. - */ - - for (i=0; i < (lc-1); i++) { - /* - * Regular component. - */ - - Tcl_AppendStringsToObj(objPtr, lv[i], NULL); - - /* - * Separator component. - */ - - i++; - if (0 == strcmp("-1", lv[i])) { - Tcl_AppendStringsToObj(objPtr, "b", NULL); - } else if (0 == strcmp("-2", lv[i])) { - Tcl_AppendStringsToObj(objPtr, "a", NULL); - } else { - Tcl_AppendStringsToObj(objPtr, ".", NULL); - } - } - - /* - * Regular component, last. - */ - - sprintf(buf, "%d", atoi(lv[lc-1]) + 1); - Tcl_AppendStringsToObj(objPtr, buf, NULL); - - ckfree((char *) iv); - ckfree((char *) lv); - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * VersionCleanupProc -- - * - * This function is called to delete the last remember package version - * string for an interpreter when the interpreter is deleted. It gets - * invoked via the Tcl AssocData mechanism. - * - * Results: - * None. - * - * Side effects: - * Storage for the version object for interp get deleted. - * - *---------------------------------------------------------------------- - */ - -static void -VersionCleanupProc( - ClientData clientData, /* Pointer to remembered version string object - * for interp. */ - Tcl_Interp *interp) /* Interpreter that is being deleted. */ -{ - Tcl_Obj *ov = clientData; - if (ov != NULL) { - TclDecrRefCount(ov); - } -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/pkg.test b/tests/pkg.test index caeeeb6..475a1f7 100644 --- a/tests/pkg.test +++ b/tests/pkg.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: pkg.test,v 1.26 2007/02/22 20:25:40 andreas_kupries Exp $ +# RCS: @(#) $Id: pkg.test,v 1.26.2.1 2007/09/11 17:58:25 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -142,7 +142,7 @@ test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} { package ifneeded t $i "set x $i" } list [catch {package require -exact t 1.3} msg] $msg -} {1 {can't find package t 1.3-1.4}} +} {1 {can't find package t exactly 1.3}} test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { package forget t package unknown {} @@ -188,7 +188,7 @@ test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { package require -exact t 1.5 package unknown {} set x -} {t 1.5-1.6} +} {t 1.5-1.5} test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { proc pkgUnknown args { package ifneeded t 1.2 "set x loaded; package provide t 1.2" @@ -245,7 +245,7 @@ test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} set result [list [catch {package require -exact t 1.5} msg] $msg $x] package unknown {} set result -} {1 {can't find package t 1.5-1.6} {t 1.5-1.6}} +} {1 {can't find package t exactly 1.5} {t 1.5-1.5}} test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { package forget t package provide t 2.3 @@ -280,7 +280,7 @@ test pkg-2.24 {Tcl_PkgRequire procedure, version checks} { package forget t package provide t 2.3 list [catch {package require -exact t 2.2} msg] $msg -} {1 {version conflict for package "t": have 2.3, need 2.2-2.3}} +} {1 {version conflict for package "t": have 2.3, need exactly 2.2}} test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body { package forget t package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI} @@ -482,7 +482,13 @@ test pkg-2.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup { package forget foo package unknown $saveUnknown } -returnCodes error -match glob -result {bad return code:*} - +test pkg-2.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { + package provide demo 1.2.3 +} -body { + package require -exact demo 1.2 +} -cleanup { + package forget demo +} -returnCodes error -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} test pkg-2.50 {Tcl_PkgRequire procedure, picking best stable version} { @@ -867,7 +873,7 @@ test pkg-7.7 {Tcl_PkgPresent procedure, not exact version} { package forget t package provide t 2.4 list [catch {package present -exact t 2.3} msg] $msg -} {1 {version conflict for package "t": have 2.4, need 2.3}} +} {1 {version conflict for package "t": have 2.4, need exactly 2.3}} test pkg-7.8 {Tcl_PkgPresent procedure, unknown package} { package forget t list [catch {package present t} msg] $msg @@ -882,16 +888,16 @@ test pkg-7.10 {Tcl_PkgPresent procedure, unknown package} { } {1 {package t 2.4 is not present}} test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} { list [catch {package present} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?version?"}} +} {1 {wrong # args: should be "package present ?-exact? package ?requirement...?"}} test pkg-7.12 {Tcl_PackageCmd procedure, "present" option} { list [catch {package present a b c} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?version?"}} +} {1 {expected version number but got "b"}} test pkg-7.13 {Tcl_PackageCmd procedure, "present" option} { list [catch {package present -exact a b c} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?version?"}} +} {1 {wrong # args: should be "package present ?-exact? package ?requirement...?"}} test pkg-7.14 {Tcl_PackageCmd procedure, "present" option} { list [catch {package present -bs a b} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?version?"}} +} {1 {expected version number but got "a"}} test pkg-7.15 {Tcl_PackageCmd procedure, "present" option} { list [catch {package present x a.b} msg] $msg } {1 {expected version number but got "a.b"}} @@ -900,10 +906,10 @@ test pkg-7.16 {Tcl_PackageCmd procedure, "present" option} { } {1 {expected version number but got "a.b"}} test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} { list [catch {package present -exact x} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?version?"}} +} {1 {wrong # args: should be "package present ?-exact? package ?requirement...?"}} test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} { list [catch {package present -exact} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?version?"}} +} {1 {wrong # args: should be "package present ?-exact? package ?requirement...?"}} -- cgit v0.12