summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2011-04-02 17:22:01 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2011-04-02 17:22:01 (GMT)
commitd2275aefb3bc8e96e7ae22e4609ba2c7604f86fe (patch)
tree0c83b53ed727a8b61d6af80643849e7f51ccac33
parentf4b7658650c49deb8518bb22558332a16264cdf6 (diff)
downloadtcl-d2275aefb3bc8e96e7ae22e4609ba2c7604f86fe.zip
tcl-d2275aefb3bc8e96e7ae22e4609ba2c7604f86fe.tar.gz
tcl-d2275aefb3bc8e96e7ae22e4609ba2c7604f86fe.tar.bz2
More generation of errorCodes ([interp], [lset], [load], [unload]).
-rw-r--r--ChangeLog3
-rw-r--r--generic/tclInterp.c161
-rw-r--r--generic/tclListObj.c6
-rw-r--r--generic/tclLoad.c36
4 files changed, 122 insertions, 84 deletions
diff --git a/ChangeLog b/ChangeLog
index f0d5bcc..3179b6e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
2011-04-02 Donal K. Fellows <dkf@users.sf.net>
+ * generic/tclInterp.c, generic/tclListObj.c, generic/tclLoad.c:
+ More generation of errorCodes ([interp], [lset], [load], [unload]).
+
* generic/tclEvent.c, generic/tclFileName.c: More generation of
errorCode information (default [bgerror] and [glob]).
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 67761ed..a156a57 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -300,8 +300,8 @@ Tcl_Init(
{
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
- return (TCL_ERROR);
- };
+ return TCL_ERROR;
+ }
}
/*
@@ -559,6 +559,7 @@ Tcl_InterpObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ Tcl_Interp *slaveInterp;
int index;
static const char *const options[] = {
"alias", "aliases", "bgerror", "cancel",
@@ -588,7 +589,7 @@ Tcl_InterpObjCmd(
}
switch ((enum option) index) {
case OPT_ALIAS: {
- Tcl_Interp *slaveInterp, *masterInterp;
+ Tcl_Interp *masterInterp;
if (objc < 4) {
aliasArgs:
@@ -622,18 +623,13 @@ Tcl_InterpObjCmd(
}
goto aliasArgs;
}
- case OPT_ALIASES: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_ALIASES:
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return AliasList(interp, slaveInterp);
- }
- case OPT_BGERROR: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_BGERROR:
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
return TCL_ERROR;
@@ -643,10 +639,8 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
- }
case OPT_CANCEL: {
int i, flags;
- Tcl_Interp *slaveInterp;
Tcl_Obj *resultObjPtr;
static const char *const cancelOptions[] = {
"-unwind", "--", NULL
@@ -680,8 +674,7 @@ Tcl_InterpObjCmd(
}
}
- endOfForLoop:
-
+ endOfForLoop:
if ((i + 2) < objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-unwind? ?--? ?path? ?result?");
@@ -689,35 +682,34 @@ Tcl_InterpObjCmd(
}
/*
- * Did they specify a slave interp to cancel the script in
- * progress in? If not, use the current interp.
+ * Did they specify a slave interp to cancel the script in progress
+ * in? If not, use the current interp.
*/
if (i < objc) {
slaveInterp = GetInterp(interp, objv[i]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
i++;
} else {
slaveInterp = interp;
}
- if (slaveInterp != NULL) {
- if (i < objc) {
- resultObjPtr = objv[i];
-
- /*
- * Tcl_CancelEval removes this reference.
- */
+ if (i < objc) {
+ resultObjPtr = objv[i];
- Tcl_IncrRefCount(resultObjPtr);
- i++;
- } else {
- resultObjPtr = NULL;
- }
+ /*
+ * Tcl_CancelEval removes this reference.
+ */
- return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
+ Tcl_IncrRefCount(resultObjPtr);
+ i++;
} else {
- return TCL_ERROR;
+ resultObjPtr = NULL;
}
+
+ return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
}
case OPT_CREATE: {
int i, last, safe;
@@ -787,13 +779,11 @@ Tcl_InterpObjCmd(
Tcl_SetObjResult(interp, slavePtr);
return TCL_OK;
}
- case OPT_DEBUG: {
- /* TIP #378 */
- Tcl_Interp *slaveInterp;
-
+ case OPT_DEBUG: /* TIP #378 */
/*
* Currently only -frame supported, otherwise ?-option ?value??
*/
+
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??");
return TCL_ERROR;
@@ -803,11 +793,9 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3);
- }
case OPT_DELETE: {
int i;
InterpInfo *iiPtr;
- Tcl_Interp *slaveInterp;
for (i = 2; i < objc; i++) {
slaveInterp = GetInterp(interp, objv[i]);
@@ -816,6 +804,8 @@ Tcl_InterpObjCmd(
} else if (slaveInterp == interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot delete the current interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "DELETESELF", NULL);
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
@@ -824,9 +814,7 @@ Tcl_InterpObjCmd(
}
return TCL_OK;
}
- case OPT_EVAL: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_EVAL:
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
return TCL_ERROR;
@@ -836,12 +824,9 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
- }
case OPT_EXISTS: {
- int exists;
- Tcl_Interp *slaveInterp;
+ int exists = 1;
- exists = 1;
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
if (objc > 3) {
@@ -853,9 +838,7 @@ Tcl_InterpObjCmd(
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
return TCL_OK;
}
- case OPT_EXPOSE: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_EXPOSE:
if ((objc < 4) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?");
return TCL_ERROR;
@@ -865,10 +848,7 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
- }
- case OPT_HIDE: {
- Tcl_Interp *slaveInterp; /* A slave. */
-
+ case OPT_HIDE:
if ((objc < 4) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?");
return TCL_ERROR;
@@ -878,30 +858,22 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
- }
- case OPT_HIDDEN: {
- Tcl_Interp *slaveInterp; /* A slave. */
-
+ case OPT_HIDDEN:
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return SlaveHidden(interp, slaveInterp);
- }
- case OPT_ISSAFE: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_ISSAFE:
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
return TCL_OK;
- }
case OPT_INVOKEHID: {
int i;
const char *namespaceName;
- Tcl_Interp *slaveInterp;
static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
@@ -944,7 +916,6 @@ Tcl_InterpObjCmd(
objv + i);
}
case OPT_LIMIT: {
- Tcl_Interp *slaveInterp;
static const char *const limitTypes[] = {
"commands", "time", NULL
};
@@ -973,9 +944,7 @@ Tcl_InterpObjCmd(
return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
}
}
- case OPT_MARKTRUSTED: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_MARKTRUSTED:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
@@ -985,10 +954,7 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveMarkTrusted(interp, slaveInterp);
- }
- case OPT_RECLIMIT: {
- Tcl_Interp *slaveInterp;
-
+ case OPT_RECLIMIT:
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
return TCL_ERROR;
@@ -998,9 +964,7 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
- }
case OPT_SLAVES: {
- Tcl_Interp *slaveInterp;
InterpInfo *iiPtr;
Tcl_Obj *resultPtr;
Tcl_HashEntry *hPtr;
@@ -1024,8 +988,7 @@ Tcl_InterpObjCmd(
}
case OPT_TRANSFER:
case OPT_SHARE: {
- Tcl_Interp *slaveInterp; /* A slave. */
- Tcl_Interp *masterInterp; /* Its master. */
+ Tcl_Interp *masterInterp; /* The master of the slave. */
Tcl_Channel chan;
if (objc != 5) {
@@ -1060,7 +1023,6 @@ Tcl_InterpObjCmd(
return TCL_OK;
}
case OPT_TARGET: {
- Tcl_Interp *slaveInterp;
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
@@ -1093,6 +1055,8 @@ Tcl_InterpObjCmd(
Tcl_AppendResult(interp, "target interpreter for alias \"",
aliasName, "\" in path \"", Tcl_GetString(objv[2]),
"\" is not my descendant", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "TARGETSHROUDED", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1437,6 +1401,8 @@ TclPreventAliasLoop(
Tcl_AppendResult(interp, "cannot define or rename alias \"",
Tcl_GetCommandName(cmdInterp, cmd),
"\": would create a loop", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "ALIASLOOP", NULL);
return TCL_ERROR;
}
@@ -2292,6 +2258,8 @@ SlaveBgerror(
|| (length < 1)) {
Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BGERRORFORMAT", NULL);
return TCL_ERROR;
}
TclSetBgErrorHandler(slaveInterp, objv[0]);
@@ -2728,8 +2696,8 @@ SlaveDebugCmd(
Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
Tcl_SetObjResult(interp, resultPtr);
} else {
- if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes,
- "debug option", 0, &debugType) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option",
+ 0, &debugType) != TCL_OK) {
return TCL_ERROR;
}
if (debugType == DEBUG_TYPE_FRAME) {
@@ -2738,11 +2706,13 @@ SlaveDebugCmd(
!= TCL_OK) {
return TCL_ERROR;
}
+
/*
- * Quietly ignore attempts to disable interp debugging.
- * This is a one-way switch as frame debug info is maintained
- * in a stack that must be consistent once turned on.
+ * Quietly ignore attempts to disable interp debugging. This
+ * is a one-way switch as frame debug info is maintained in a
+ * stack that must be consistent once turned on.
*/
+
if (debugType) {
iPtr->flags |= INTERP_DEBUG_FRAME;
}
@@ -2847,6 +2817,8 @@ SlaveExpose(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot expose commands",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
@@ -2890,6 +2862,8 @@ SlaveRecursionLimit(
if (Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "permission denied: "
"safe interpreters cannot change recursion limit", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
@@ -2898,6 +2872,8 @@ SlaveRecursionLimit(
if (limit <= 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"recursion limit must be > 0", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
+ NULL);
return TCL_ERROR;
}
Tcl_SetRecursionLimit(slaveInterp, limit);
@@ -2905,6 +2881,7 @@ SlaveRecursionLimit(
if (interp == slaveInterp && iPtr->numLevels > limit) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"falling back due to new recursion limit", -1));
+ Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[0]);
@@ -2946,6 +2923,8 @@ SlaveHide(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot hide commands",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
@@ -3028,6 +3007,8 @@ SlaveInvokeHidden(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not allowed to invoke hidden commands from safe interpreter",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
@@ -3082,6 +3063,8 @@ SlaveMarkTrusted(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot mark trusted",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
@@ -3339,6 +3322,7 @@ Tcl_LimitCheck(
} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "command count limit exceeded", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
@@ -3364,6 +3348,7 @@ Tcl_LimitCheck(
} else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "time limit exceeded", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
@@ -4429,8 +4414,7 @@ SlaveCommandLimitCmd(
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
- Tcl_WrongNumArgs(interp, consumedObjc, objv,
- "?-option value ...?");
+ Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int i, scriptLen = 0, limitLen = 0;
@@ -4455,6 +4439,8 @@ SlaveCommandLimitCmd(
if (gran < 1) {
Tcl_AppendResult(interp, "granularity must be at "
"least 1", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
break;
@@ -4470,6 +4456,8 @@ SlaveCommandLimitCmd(
if (limit < 0) {
Tcl_AppendResult(interp, "command limit value must be at "
"least 0", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
break;
@@ -4617,8 +4605,7 @@ SlaveTimeLimitCmd(
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
- Tcl_WrongNumArgs(interp, consumedObjc, objv,
- "?-option value ...?");
+ Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int i, scriptLen = 0, milliLen = 0, secLen = 0;
@@ -4647,6 +4634,8 @@ SlaveTimeLimitCmd(
if (gran < 1) {
Tcl_AppendResult(interp, "granularity must be at "
"least 1", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
break;
@@ -4662,6 +4651,8 @@ SlaveTimeLimitCmd(
if (tmp < 0) {
Tcl_AppendResult(interp, "milliseconds must be at least 0",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
limitMoment.usec = ((long)tmp)*1000;
@@ -4678,6 +4669,8 @@ SlaveTimeLimitCmd(
if (tmp < 0) {
Tcl_AppendResult(interp, "seconds must be at least 0",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADVALUE", NULL);
return TCL_ERROR;
}
limitMoment.sec = tmp;
@@ -4694,11 +4687,15 @@ SlaveTimeLimitCmd(
if (secObj != NULL && secLen == 0 && milliLen > 0) {
Tcl_AppendResult(interp, "may only set -milliseconds "
"if -seconds is not also being reset", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADUSAGE", NULL);
return TCL_ERROR;
}
if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
Tcl_AppendResult(interp, "may only reset -milliseconds "
"if -seconds is also being reset", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+ "BADUSAGE", NULL);
return TCL_ERROR;
}
}
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index b27163d..9128333 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -1339,6 +1339,8 @@ TclLsetFlat(
/* ...the index points outside the sublist. */
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
+ NULL);
break;
}
@@ -1511,6 +1513,8 @@ TclListObjSetElement(
if (!length) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
+ NULL);
return TCL_ERROR;
}
result = SetListFromAny(interp, listPtr);
@@ -1531,6 +1535,8 @@ TclListObjSetElement(
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
+ NULL);
}
return TCL_ERROR;
}
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 371a437..707d6ec 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -160,6 +160,8 @@ Tcl_LoadObjCmd(
Tcl_SetResult(interp,
"must specify either file name or package name",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -226,6 +228,8 @@ Tcl_LoadObjCmd(
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" is already loaded for package \"",
pkgPtr->packageName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
+ "SPLITPERSONALITY", NULL);
code = TCL_ERROR;
Tcl_MutexUnlock(&packageMutex);
goto done;
@@ -261,6 +265,8 @@ Tcl_LoadObjCmd(
if (fullFileName[0] == 0) {
Tcl_AppendResult(interp, "package \"", packageName,
"\" isn't loaded statically", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -312,6 +318,8 @@ Tcl_LoadObjCmd(
Tcl_AppendResult(interp,
"couldn't figure out package name for ",
fullFileName, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
+ "WHATPACKAGE", NULL);
code = TCL_ERROR;
goto done;
}
@@ -407,11 +415,22 @@ Tcl_LoadObjCmd(
Tcl_AppendResult(interp,
"can't use package in a safe interpreter: no ",
pkgPtr->packageName, "_SafeInit procedure", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE",
+ NULL);
code = TCL_ERROR;
goto done;
}
code = pkgPtr->safeInitProc(target);
} else {
+ if (pkgPtr->initProc == NULL) {
+ Tcl_AppendResult(interp,
+ "can't attach package to interpreter: no ",
+ pkgPtr->packageName, "_Init procedure", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT",
+ NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
code = pkgPtr->initProc(target);
}
@@ -555,6 +574,8 @@ Tcl_UnloadObjCmd(
Tcl_SetResult(interp,
"must specify either file name or package name",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -626,6 +647,8 @@ Tcl_UnloadObjCmd(
Tcl_AppendResult(interp, "package \"", packageName,
"\" is loaded statically and cannot be unloaded", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -636,6 +659,8 @@ Tcl_UnloadObjCmd(
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" has never been loaded", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -663,6 +688,8 @@ Tcl_UnloadObjCmd(
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" has never been loaded in this interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -677,6 +704,8 @@ Tcl_UnloadObjCmd(
if (pkgPtr->safeUnloadProc == NULL) {
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" cannot be unloaded under a safe interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -685,6 +714,8 @@ Tcl_UnloadObjCmd(
if (pkgPtr->unloadProc == NULL) {
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" cannot be unloaded under a trusted interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ NULL);
code = TCL_ERROR;
goto done;
}
@@ -771,8 +802,7 @@ Tcl_UnloadObjCmd(
*/
if (pkgPtr->fileName[0] != '\0') {
-
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&packageMutex);
if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) {
/*
* Remove this library from the loaded library cache.
@@ -824,6 +854,8 @@ Tcl_UnloadObjCmd(
#else
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" cannot be unloaded: unloading disabled", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED",
+ NULL);
code = TCL_ERROR;
#endif
}