summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCompCmds.c50
-rw-r--r--generic/tclCompile.c6
-rw-r--r--generic/tclExecute.c37
-rw-r--r--generic/tclLink.c11
-rw-r--r--generic/tclPkg.c333
5 files changed, 162 insertions, 275 deletions
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 <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit>
@@ -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
generated by cgit v0.12 at 2024-11-22 12:33:33 (GMT)